LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-21 11:03:29 +01:00
Code Releases Activity

Merge pull request #19 from QuantumPackage/dev-stable

Browse Source 
Dev stable
This commit is contained in:
AbdAmmar 2023-06-20 20:16:16 +02:00 committed by GitHub
commit fca309a5b2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
36 changed files with 1150 additions and 666 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
ocaml/qp_run.ml
View File

@ -38,7 +38,8 @@ let run slave ?prefix exe ezfio_file =
| Unix.Unix_error _ -> try_new_port (port_number+100)
in
let result =
try_new_port 41279
let port = 10*(Unix.getpid () mod 2823) + 32_769 in
try_new_port port
in
Zmq.Socket.close dummy_socket;
Zmq.Context.terminate zmq_context;

2
scripts/compilation/cache_compile.py
View File

@ -1,7 +1,7 @@
#!/usr/bin/env python3
"""
Save the .o from a .f90
and is the .o is asked a second time, retur it
and is the .o is asked a second time, return it
Take in argv command like:
ifort -g -openmp -I IRPF90_temp/Ezfio_files/ -c IRPF90_temp/Integrals_Monoelec/kin_ao_ints.irp.module.F90 -o IRPF90_temp/Integrals_Monoelec/kin_ao_ints.irp.module.o
"""

3
src/ao_one_e_ints/pot_ao_ints.irp.f
View File

@ -104,6 +104,9 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
IF(do_pseudo) THEN
ao_integrals_n_e += ao_pseudo_integrals
ENDIF
IF(point_charges) THEN
ao_integrals_n_e += ao_integrals_pt_chrg
ENDIF
endif

13
src/ao_two_e_ints/cholesky.irp.f
View File

@ -4,7 +4,7 @@ BEGIN_PROVIDER [ integer, cholesky_ao_num_guess ]
! Number of Cholesky vectors in AO basis
END_DOC
cholesky_ao_num_guess = ao_num*ao_num / 2
cholesky_ao_num_guess = ao_num*ao_num
END_PROVIDER
BEGIN_PROVIDER [ integer, cholesky_ao_num ]
@ -44,19 +44,12 @@ END_PROVIDER
do m=0,9
do l=1+m,ao_num,10
!$OMP DO SCHEDULE(dynamic)
do j=1,l
do j=1,ao_num
do k=1,ao_num
do i=1,min(k,j)
do i=1,ao_num
if (ao_two_e_integral_zero(i,j,k,l)) cycle
integral = get_ao_two_e_integral(i,j,k,l, ao_integrals_map)
ao_integrals(i,k,j,l) = integral
ao_integrals(k,i,j,l) = integral
ao_integrals(i,k,l,j) = integral
ao_integrals(k,i,l,j) = integral
ao_integrals(j,l,i,k) = integral
ao_integrals(j,l,k,i) = integral
ao_integrals(l,j,i,k) = integral
ao_integrals(l,j,k,i) = integral
enddo
enddo
enddo

48
src/bi_ort_ints/bi_ort_ints.irp.f
View File

@ -88,7 +88,6 @@ subroutine test_5idx
! if (dabs(three_e_5_idx_direct_bi_ort(m,l,j,k,i) - three_e_5_idx_exch12_bi_ort(m,l,i,k,j)) > 1.d-10) then
! stop
! endif
new = three_e_5_idx_direct_bi_ort(m,l,j,k,i)
ref = three_e_5_idx_direct_bi_ort_old(m,l,j,k,i)
contrib = dabs(new - ref)
@ -118,6 +117,51 @@ subroutine test_5idx
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'cycle1'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_cycle_2_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'cycle2'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_exch23_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_exch23_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'exch23'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_exch13_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_exch13_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'exch13'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_cycle_1_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'cycle1'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
@ -155,7 +199,7 @@ subroutine test_5idx
! print*,ref,new,contrib
! stop
! endif
!
enddo
enddo
enddo

2
src/bi_ort_ints/three_body_ijmkl.irp.f
View File

@ -65,7 +65,7 @@ end
tmp_mat = 0.d0
call print_memory_usage
!
do m = 1, mo_num
allocate(grad_mli(n_points_final_grid,mo_num))

11
src/ccsd/EZFIO.cfg Normal file
View File

@ -0,0 +1,11 @@
[energy]
type: double precision
doc: CCSD energy
interface: ezfio
[energy_t]
type: double precision
doc: CCSD(T) energy
interface: ezfio

11
src/ccsd/ccsd_space_orb_sub.irp.f
View File

@ -135,8 +135,11 @@ subroutine run_ccsd_space_orb
write(*,'(A15,1pE10.2,A3)')' Conv = ', max_r
print*,''
call write_t1(nO,nV,t1)
call write_t2(nO,nV,t2)
if (write_amplitudes) then
call write_t1(nO,nV,t1)
call write_t2(nO,nV,t2)
call ezfio_set_utils_cc_io_amplitudes('Read')
endif
! Deallocation
if (cc_update_method == 'diis') then
@ -147,6 +150,7 @@ subroutine run_ccsd_space_orb
! CCSD(T)
double precision :: e_t
e_t = 0.d0
if (cc_par_t .and. elec_alpha_num + elec_beta_num > 2) then
@ -182,8 +186,7 @@ subroutine run_ccsd_space_orb
print*,''
endif
print*,'Reference determinant:'
call print_det(det,N_int)
call save_energy(uncorr_energy + energy, e_t)
deallocate(t1,t2)

14
src/ccsd/ccsd_spin_orb_sub.irp.f
View File

@ -269,8 +269,11 @@ subroutine run_ccsd_spin_orb
write(*,'(A15,1pE10.2,A3)')' Conv = ', max_r
print*,''
call write_t1(nO,nV,t1)
call write_t2(nO,nV,t2)
if (write_amplitudes) then
call write_t1(nO,nV,t1)
call write_t2(nO,nV,t2)
call ezfio_set_utils_cc_io_amplitudes('Read')
endif
! Deallocate
if (cc_update_method == 'diis') then
@ -284,8 +287,9 @@ subroutine run_ccsd_spin_orb
deallocate(v_ovoo,v_oovo)
deallocate(v_ovvo,v_ovov,v_oovv)
double precision :: t_corr
t_corr = 0.d0
if (cc_par_t .and. elec_alpha_num +elec_beta_num > 2) then
double precision :: t_corr
print*,'CCSD(T) calculation...'
call wall_time(ta)
!allocate(v_vvvo(nV,nV,nV,nO))
@ -307,8 +311,8 @@ subroutine run_ccsd_spin_orb
write(*,'(A15,F18.12,A3)') ' Correlation = ', energy + t_corr, ' Ha'
print*,''
endif
print*,'Reference determinant:'
call print_det(det,N_int)
call save_energy(uncorr_energy + energy, t_corr)
deallocate(f_oo,f_ov,f_vv,f_o,f_v)
deallocate(v_ooov,v_vvoo,t1,t2)

82
src/ccsd/ccsd_t_space_orb_stoch.irp.f
View File

@ -104,17 +104,17 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
integer*8, allocatable :: sampled(:)
! integer(omp_lock_kind), allocatable :: lock(:)
integer*2 , allocatable :: abc(:,:)
integer*8 :: Nabc, i8
integer*8 :: Nabc, i8,kiter
integer*8, allocatable :: iorder(:)
double precision :: eocc
double precision :: norm
integer :: kiter, isample
integer :: isample
! Prepare table of triplets (a,b,c)
Nabc = (int(nV,8) * int(nV+1,8) * int(nV+2,8))/6_8 - nV
allocate (memo(Nabc), sampled(Nabc), Pabc(Nabc), waccu(Nabc))
allocate (memo(Nabc), sampled(Nabc), Pabc(Nabc), waccu(0:Nabc))
allocate (abc(4,Nabc), iorder(Nabc)) !, lock(Nabc))
! eocc = 3.d0/dble(nO) * sum(f_o(1:nO))
@ -124,21 +124,21 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
do c = b+1, nV
Nabc = Nabc + 1_8
Pabc(Nabc) = -1.d0/(f_v(a) + f_v(b) + f_v(c))
abc(1,Nabc) = a
abc(2,Nabc) = b
abc(3,Nabc) = c
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(c,2)
enddo
Nabc = Nabc + 1_8
abc(1,Nabc) = a
abc(2,Nabc) = b
abc(3,Nabc) = a
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(a,2)
Pabc(Nabc) = -1.d0/(2.d0*f_v(a) + f_v(b))
Nabc = Nabc + 1_8
abc(1,Nabc) = b
abc(2,Nabc) = a
abc(3,Nabc) = b
abc(1,Nabc) = int(b,2)
abc(2,Nabc) = int(a,2)
abc(3,Nabc) = int(b,2)
Pabc(Nabc) = -1.d0/(f_v(a) + 2.d0*f_v(b))
enddo
enddo
@ -169,6 +169,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
waccu(i8) = waccu(i8+1) - Pabc(i8+1)
enddo
waccu(:) = waccu(:) + 1.d0
waccu(0) = 0.d0
logical :: converged, do_comp
double precision :: eta, variance, error, sample
@ -222,8 +223,12 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
do kiter=1,Nabc
!$OMP MASTER
do while ((imin <= Nabc).and.(sampled(imin)>-1_8))
imin = imin+1
do while (imin <= Nabc)
if (sampled(imin)>-1_8) then
imin = imin+1
else
exit
endif
enddo
! Deterministic part
@ -301,6 +306,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
endif
enddo
isample = min(isample,nbuckets)
do ieta=bounds(1,isample), Nabc
w = dble(max(sampled(ieta),0_8))
tmp = w * memo(ieta) * Pabc(ieta)
@ -331,33 +337,39 @@ end
integer*8 function binary_search(arr, key, size)
integer*8 function binary_search(arr, key, sze)
implicit none
BEGIN_DOC
! Searches the key in array arr(1:size) between l_in and r_in, and returns its index
! Searches the key in array arr(1:sze) between l_in and r_in, and returns its index
END_DOC
integer*8 :: size, i, j, mid, l_in, r_in
double precision, dimension(size) :: arr(1:size)
integer*8 :: sze, i, j, mid
double precision :: arr(0:sze)
double precision :: key
i = 1_8
j = size
if ( key < arr(1) ) then
binary_search = 0_8
return
end if
do while (j >= i)
mid = i + (j - i) / 2
if (arr(mid) >= key) then
if (mid > 1 .and. arr(mid - 1) < key) then
binary_search = mid
return
end if
j = mid - 1
else if (arr(mid) < key) then
i = mid + 1
else
binary_search = mid + 1
return
end if
if ( key >= arr(sze) ) then
binary_search = sze
return
end if
i = 0_8
j = sze + 1_8
do while (.True.)
mid = (i + j) / 2_8
if ( key >= arr(mid) ) then
i = mid
else
j = mid
end if
if (j-i <= 1_8) then
binary_search = i
return
endif
end do
binary_search = i
end function binary_search

13
src/ccsd/save_energy.irp.f Normal file
View File

@ -0,0 +1,13 @@
subroutine save_energy(E,ET)
implicit none
BEGIN_DOC
! Saves the energy in |EZFIO|.
END_DOC
double precision, intent(in) :: E, ET
call ezfio_set_ccsd_energy(E)
if (ET /= 0.d0) then
call ezfio_set_ccsd_energy_t(E+ET)
endif
end

423
src/cipsi/selection.irp.f
View File

@ -88,6 +88,10 @@ subroutine select_connected(i_generator,E0,pt2_data,b,subset,csubset)
particle_mask(k,1) = iand(generators_bitmask(k,1,s_part), not(psi_det_generators(k,1,i_generator)) )
particle_mask(k,2) = iand(generators_bitmask(k,2,s_part), not(psi_det_generators(k,2,i_generator)) )
enddo
if ((subset == 1).and.(sum(hole_mask(:,2)) == 0_bit_kind)) then
! No beta electron to excite
call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b)
endif
call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b,subset,csubset)
deallocate(fock_diag_tmp)
end subroutine
@ -142,7 +146,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
use selection_types
implicit none
BEGIN_DOC
! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
END_DOC
integer, intent(in) :: i_generator, subset, csubset
@ -237,7 +241,6 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
enddo
! Iterate on 0S alpha, and find betas TQ such that exc_degree <= 4
! Remove also contributions < 1.d-20)
do j=1,N_det_alpha_unique
call get_excitation_degree_spin(psi_det_alpha_unique(1,j), &
psi_det_generators(1,1,i_generator), nt, N_int)
@ -480,7 +483,9 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
do s2=s1,2
sp = s1
if(s1 /= s2) sp = 3
if(s1 /= s2) then
sp = 3
endif
ib = 1
if(s1 == s2) ib = i1+1
@ -528,7 +533,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
deallocate(preinteresting, prefullinteresting, interesting, fullinteresting)
deallocate(banned, bannedOrb,mat)
end subroutine
subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf)
BEGIN_TEMPLATE
subroutine fill_buffer_$DOUBLE(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf)
use bitmasks
use selection_types
implicit none
@ -562,7 +570,20 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
s1 = sp
s2 = sp
end if
call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int)
if ($IS_DOUBLE) then
if (h2 == 0) then
print *, 'h2=0 in '//trim(irp_here)
stop
endif
call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int)
else
if (h2 /= 0) then
print *, 'h2 /= in '//trim(irp_here)
stop
endif
call apply_hole(psi_det_generators(1,1,i_generator), s1, h1, mask, ok, N_int)
endif
E_shift = 0.d0
if (h0_type == 'CFG') then
@ -570,12 +591,15 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
E_shift = psi_det_Hii(i_generator) - psi_configuration_Hii(j)
endif
do p1=1,mo_num
if(bannedOrb(p1, s1)) cycle
$DO_p1
! do p1=1,mo_num
if (bannedOrb(p1, s1)) cycle
ib = 1
if(sp /= 3) ib = p1+1
do p2=ib,mo_num
$DO_p2
! do p2=ib,mo_num
! -----
! /!\ Generating only single excited determinants doesn't work because a
@ -584,9 +608,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
! detected as already generated when generating in the future with a
! double excitation.
! -----
if(bannedOrb(p2, s2)) cycle
if(banned(p1,p2)) cycle
if ($IS_DOUBLE) then
if(bannedOrb(p2, s2)) cycle
if(banned(p1,p2)) cycle
endif
if(pseudo_sym)then
if(dabs(mat(1, p1, p2)).lt.thresh_sym)then
@ -596,7 +621,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
val = maxval(abs(mat(1:N_states, p1, p2)))
if( val == 0d0) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
if ($IS_DOUBLE) then
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
else
call apply_particle(mask, s1, p1, det, ok, N_int)
endif
if (do_only_cas) then
integer, external :: number_of_holes, number_of_particles
@ -857,10 +886,19 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
if(w <= buf%mini) then
call add_to_selection_buffer(buf, det, w)
end if
end do
end do
! enddo
$ENDDO_p1
! enddo
$ENDDO_p2
end
SUBST [ DOUBLE , DO_p1 , ENDDO_p1 , DO_p2 , ENDDO_p2 , IS_DOUBLE ]
double ; do p1=1,mo_num ; enddo ; do p2=ib,mo_num ; enddo ; .True. ;;
single ; do p1=1,mo_num ; enddo ; p2=1 ; ; .False. ;;
END_TEMPLATE
subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting)
use bitmasks
implicit none
@ -882,6 +920,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
PROVIDE psi_selectors_coef_transp psi_det_sorted
mat = 0d0
p=0
do i=1,N_int
negMask(i,1) = not(mask(i,1))
@ -1435,7 +1474,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
p1 = p(1,sp)
p2 = p(2,sp)
do puti=1, mo_num
if(bannedOrb(puti, sp)) cycle
if (bannedOrb(puti, sp)) cycle
call get_mo_two_e_integrals(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map)
call get_mo_two_e_integrals(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map)
do putj=puti+1, mo_num
@ -1446,7 +1485,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
call i_h_j(gen, det, N_int, hij)
if (hij == 0.d0) cycle
else
hij = (mo_two_e_integral(p1, p2, puti, putj) - mo_two_e_integral(p2, p1, puti, putj))
hij = hij_cache1(putj) - hij_cache2(putj)
if (hij == 0.d0) cycle
hij = hij * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
end if
@ -1506,7 +1545,7 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting)
use bitmasks
implicit none
BEGIN_DOC
! Identify the determinants in det which are in the internal space. These are
! Identify the determinants in det that are in the internal space. These are
! the determinants that can be produced by creating two particles on the mask.
END_DOC
@ -1534,7 +1573,7 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting)
if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl
end do
! If det(i) < det(i_gen), it hs already been considered
! If det(i) < det(i_gen), it has already been considered
if(interesting(i) < i_gen) then
fullMatch = .true.
return
@ -1585,352 +1624,4 @@ end
! OLD unoptimized routines for debugging
! ======================================
subroutine get_d0_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int,2)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
integer(bit_kind) :: det(N_int, 2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
integer :: i, j, s, h1, h2, p1, p2, puti, putj
double precision :: hij, phase
double precision, external :: get_phase_bi, mo_two_e_integral
logical :: ok
integer :: bant
bant = 1
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
do p1=1, mo_num
if(bannedOrb(p1, 1)) cycle
do p2=1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, bant)) cycle ! rentable?
if(p1 == h1 .or. p2 == h2) then
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = mo_two_e_integral(p1, p2, h1, h2) * phase
end if
mat(:, p1, p2) = mat(:, p1, p2) + coefs(:) * hij
end do
end do
else ! AA BB
p1 = p(1,sp)
p2 = p(2,sp)
do puti=1, mo_num
if(bannedOrb(puti, sp)) cycle
do putj=puti+1, mo_num
if(bannedOrb(putj, sp)) cycle
if(banned(puti, putj, bant)) cycle ! rentable?
if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
else
hij = (mo_two_e_integral(p1, p2, puti, putj) - mo_two_e_integral(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
end if
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
end if
end
subroutine get_d1_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int,2)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
integer(bit_kind) :: det(N_int, 2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision :: hij, tmp_row(N_states, mo_num), tmp_row2(N_states, mo_num)
double precision, external :: get_phase_bi, mo_two_e_integral
logical :: ok
logical, allocatable :: lbanned(:,:)
integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
integer :: hfix, pfix, h1, h2, p1, p2, ib
integer, parameter :: turn2(2) = (/2,1/)
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer :: bant
allocate (lbanned(mo_num, 2))
lbanned = bannedOrb
do i=1, p(0,1)
lbanned(p(i,1), 1) = .true.
end do
do i=1, p(0,2)
lbanned(p(i,2), 2) = .true.
end do
ma = 1
if(p(0,2) >= 2) ma = 2
mi = turn2(ma)
bant = 1
if(sp == 3) then
!move MA
if(ma == 2) bant = 2
puti = p(1,mi)
hfix = h(1,ma)
p1 = p(1,ma)
p2 = p(2,ma)
if(.not. bannedOrb(puti, mi)) then
tmp_row = 0d0
do putj=1, hfix-1
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle
hij = (mo_two_e_integral(p1, p2, putj, hfix)-mo_two_e_integral(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_row(1:N_states,putj) = tmp_row(1:N_states,putj) + hij * coefs(1:N_states)
end do
do putj=hfix+1, mo_num
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle
hij = (mo_two_e_integral(p1, p2, hfix, putj)-mo_two_e_integral(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_row(1:N_states,putj) = tmp_row(1:N_states,putj) + hij * coefs(1:N_states)
end do
if(ma == 1) then
mat(1:N_states,1:mo_num,puti) = mat(1:N_states,1:mo_num,puti) + tmp_row(1:N_states,1:mo_num)
else
mat(1:N_states,puti,1:mo_num) = mat(1:N_states,puti,1:mo_num) + tmp_row(1:N_states,1:mo_num)
end if
end if
!MOVE MI
pfix = p(1,mi)
tmp_row = 0d0
tmp_row2 = 0d0
do puti=1,mo_num
if(lbanned(puti,mi)) cycle
!p1 fixed
putj = p1
if(.not. banned(putj,puti,bant)) then
hij = mo_two_e_integral(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
tmp_row(:,puti) = tmp_row(:,puti) + hij * coefs(:)
end if
putj = p2
if(.not. banned(putj,puti,bant)) then
hij = mo_two_e_integral(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
tmp_row2(:,puti) = tmp_row2(:,puti) + hij * coefs(:)
end if
end do
if(mi == 1) then
mat(:,:,p1) = mat(:,:,p1) + tmp_row(:,:)
mat(:,:,p2) = mat(:,:,p2) + tmp_row2(:,:)
else
mat(:,p1,:) = mat(:,p1,:) + tmp_row(:,:)
mat(:,p2,:) = mat(:,p2,:) + tmp_row2(:,:)
end if
else
if(p(0,ma) == 3) then
do i=1,3
hfix = h(1,ma)
puti = p(i, ma)
p1 = p(turn3(1,i), ma)
p2 = p(turn3(2,i), ma)
tmp_row = 0d0
do putj=1,hfix-1
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_two_e_integral(p1, p2, putj, hfix)-mo_two_e_integral(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_row(:,putj) = tmp_row(:,putj) + hij * coefs(:)
end do
do putj=hfix+1,mo_num
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_two_e_integral(p1, p2, hfix, putj)-mo_two_e_integral(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_row(:,putj) = tmp_row(:,putj) + hij * coefs(:)
end do
mat(:, :puti-1, puti) = mat(:, :puti-1, puti) + tmp_row(:,:puti-1)
mat(:, puti, puti:) = mat(:, puti, puti:) + tmp_row(:,puti:)
end do
else
hfix = h(1,mi)
pfix = p(1,mi)
p1 = p(1,ma)
p2 = p(2,ma)
tmp_row = 0d0
tmp_row2 = 0d0
do puti=1,mo_num
if(lbanned(puti,ma)) cycle
putj = p2
if(.not. banned(puti,putj,1)) then
hij = mo_two_e_integral(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
tmp_row(:,puti) = tmp_row(:,puti) + hij * coefs(:)
end if
putj = p1
if(.not. banned(puti,putj,1)) then
hij = mo_two_e_integral(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
tmp_row2(:,puti) = tmp_row2(:,puti) + hij * coefs(:)
end if
end do
mat(:,:p2-1,p2) = mat(:,:p2-1,p2) + tmp_row(:,:p2-1)
mat(:,p2,p2:) = mat(:,p2,p2:) + tmp_row(:,p2:)
mat(:,:p1-1,p1) = mat(:,:p1-1,p1) + tmp_row2(:,:p1-1)
mat(:,p1,p1:) = mat(:,p1,p1:) + tmp_row2(:,p1:)
end if
end if
deallocate(lbanned)
!! MONO
if(sp == 3) then
s1 = 1
s2 = 2
else
s1 = sp
s2 = sp
end if
do i1=1,p(0,s1)
ib = 1
if(s1 == s2) ib = i1+1
do i2=ib,p(0,s2)
p1 = p(i1,s1)
p2 = p(i2,s2)
if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
mat(:, p1, p2) = mat(:, p1, p2) + coefs(:) * hij
end do
end do
end
subroutine get_d2_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(2,N_int)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision, external :: get_phase_bi, mo_two_e_integral
integer :: i, j, tip, ma, mi, puti, putj
integer :: h1, h2, p1, p2, i1, i2
double precision :: hij, phase
integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/))
integer, parameter :: turn2(2) = (/2, 1/)
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer :: bant
bant = 1
tip = p(0,1) * p(0,2)
ma = sp
if(p(0,1) > p(0,2)) ma = 1
if(p(0,1) < p(0,2)) ma = 2
mi = mod(ma, 2) + 1
if(sp == 3) then
if(ma == 2) bant = 2
if(tip == 3) then
puti = p(1, mi)
do i = 1, 3
putj = p(i, ma)
if(banned(putj,puti,bant)) cycle
i1 = turn3(1,i)
i2 = turn3(2,i)
p1 = p(i1, ma)
p2 = p(i2, ma)
h1 = h(1, ma)
h2 = h(2, ma)
hij = (mo_two_e_integral(p1, p2, h1, h2) - mo_two_e_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
if(ma == 1) then
mat(:, putj, puti) = mat(:, putj, puti) + coefs(:) * hij
else
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end if
end do
else
h1 = h(1,1)
h2 = h(1,2)
do j = 1,2
putj = p(j, 2)
p2 = p(turn2(j), 2)
do i = 1,2
puti = p(i, 1)
if(banned(puti,putj,bant)) cycle
p1 = p(turn2(i), 1)
hij = mo_two_e_integral(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
end if
else
if(tip == 0) then
h1 = h(1, ma)
h2 = h(2, ma)
do i=1,3
puti = p(i, ma)
do j=i+1,4
putj = p(j, ma)
if(banned(puti,putj,1)) cycle
i1 = turn2d(1, i, j)
i2 = turn2d(2, i, j)
p1 = p(i1, ma)
p2 = p(i2, ma)
hij = (mo_two_e_integral(p1, p2, h1, h2) - mo_two_e_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
else if(tip == 3) then
h1 = h(1, mi)
h2 = h(1, ma)
p1 = p(1, mi)
do i=1,3
puti = p(turn3(1,i), ma)
putj = p(turn3(2,i), ma)
if(banned(puti,putj,1)) cycle
p2 = p(i, ma)
hij = mo_two_e_integral(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2,N_int)
mat(:, min(puti, putj), max(puti, putj)) = mat(:, min(puti, putj), max(puti, putj)) + coefs(:) * hij
end do
else ! tip == 4
puti = p(1, sp)
putj = p(2, sp)
if(.not. banned(puti,putj,1)) then
p1 = p(1, mi)
p2 = p(2, mi)
h1 = h(1, mi)
h2 = h(2, mi)
hij = (mo_two_e_integral(p1, p2, h1, h2) - mo_two_e_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end if
end if
end if
end

350
src/cipsi/selection_old.irp.f Normal file
View File

@ -0,0 +1,350 @@
! OLD unoptimized routines for debugging
! ======================================
subroutine get_d0_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int,2)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
integer(bit_kind) :: det(N_int, 2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
integer :: i, j, s, h1, h2, p1, p2, puti, putj
double precision :: hij, phase
double precision, external :: get_phase_bi, mo_two_e_integral
logical :: ok
integer :: bant
bant = 1
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
do p1=1, mo_num
if(bannedOrb(p1, 1)) cycle
do p2=1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, bant)) cycle ! rentable?
if(p1 == h1 .or. p2 == h2) then
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = mo_two_e_integral(p1, p2, h1, h2) * phase
end if
mat(:, p1, p2) = mat(:, p1, p2) + coefs(:) * hij
end do
end do
else ! AA BB
p1 = p(1,sp)
p2 = p(2,sp)
do puti=1, mo_num
! do not cycle here? otherwise singles will be missed??
if(bannedOrb(puti, sp)) cycle
do putj=puti+1, mo_num
if(bannedOrb(putj, sp)) cycle
if(banned(puti, putj, bant)) cycle ! rentable?
if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
else
hij = (mo_two_e_integral(p1, p2, puti, putj) - mo_two_e_integral(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
end if
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
end if
end
subroutine get_d1_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int,2)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
integer(bit_kind) :: det(N_int, 2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision :: hij, tmp_row(N_states, mo_num), tmp_row2(N_states, mo_num)
double precision, external :: get_phase_bi, mo_two_e_integral
logical :: ok
logical, allocatable :: lbanned(:,:)
integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
integer :: hfix, pfix, h1, h2, p1, p2, ib
integer, parameter :: turn2(2) = (/2,1/)
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer :: bant
allocate (lbanned(mo_num, 2))
lbanned = bannedOrb
do i=1, p(0,1)
lbanned(p(i,1), 1) = .true.
end do
do i=1, p(0,2)
lbanned(p(i,2), 2) = .true.
end do
ma = 1
if(p(0,2) >= 2) ma = 2
mi = turn2(ma)
bant = 1
if(sp == 3) then
!move MA
if(ma == 2) bant = 2
puti = p(1,mi)
hfix = h(1,ma)
p1 = p(1,ma)
p2 = p(2,ma)
if(.not. bannedOrb(puti, mi)) then
tmp_row = 0d0
do putj=1, hfix-1
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle
hij = (mo_two_e_integral(p1, p2, putj, hfix)-mo_two_e_integral(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_row(1:N_states,putj) = tmp_row(1:N_states,putj) + hij * coefs(1:N_states)
end do
do putj=hfix+1, mo_num
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle
hij = (mo_two_e_integral(p1, p2, hfix, putj)-mo_two_e_integral(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_row(1:N_states,putj) = tmp_row(1:N_states,putj) + hij * coefs(1:N_states)
end do
if(ma == 1) then
mat(1:N_states,1:mo_num,puti) = mat(1:N_states,1:mo_num,puti) + tmp_row(1:N_states,1:mo_num)
else
mat(1:N_states,puti,1:mo_num) = mat(1:N_states,puti,1:mo_num) + tmp_row(1:N_states,1:mo_num)
end if
end if
!MOVE MI
pfix = p(1,mi)
tmp_row = 0d0
tmp_row2 = 0d0
do puti=1,mo_num
if(lbanned(puti,mi)) cycle
!p1 fixed
putj = p1
if(.not. banned(putj,puti,bant)) then
hij = mo_two_e_integral(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
tmp_row(:,puti) = tmp_row(:,puti) + hij * coefs(:)
end if
putj = p2
if(.not. banned(putj,puti,bant)) then
hij = mo_two_e_integral(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
tmp_row2(:,puti) = tmp_row2(:,puti) + hij * coefs(:)
end if
end do
if(mi == 1) then
mat(:,:,p1) = mat(:,:,p1) + tmp_row(:,:)
mat(:,:,p2) = mat(:,:,p2) + tmp_row2(:,:)
else
mat(:,p1,:) = mat(:,p1,:) + tmp_row(:,:)
mat(:,p2,:) = mat(:,p2,:) + tmp_row2(:,:)
end if
else
if(p(0,ma) == 3) then
do i=1,3
hfix = h(1,ma)
puti = p(i, ma)
p1 = p(turn3(1,i), ma)
p2 = p(turn3(2,i), ma)
tmp_row = 0d0
do putj=1,hfix-1
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_two_e_integral(p1, p2, putj, hfix)-mo_two_e_integral(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_row(:,putj) = tmp_row(:,putj) + hij * coefs(:)
end do
do putj=hfix+1,mo_num
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_two_e_integral(p1, p2, hfix, putj)-mo_two_e_integral(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_row(:,putj) = tmp_row(:,putj) + hij * coefs(:)
end do
mat(:, :puti-1, puti) = mat(:, :puti-1, puti) + tmp_row(:,:puti-1)
mat(:, puti, puti:) = mat(:, puti, puti:) + tmp_row(:,puti:)
end do
else
hfix = h(1,mi)
pfix = p(1,mi)
p1 = p(1,ma)
p2 = p(2,ma)
tmp_row = 0d0
tmp_row2 = 0d0
do puti=1,mo_num
if(lbanned(puti,ma)) cycle
putj = p2
if(.not. banned(puti,putj,1)) then
hij = mo_two_e_integral(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
tmp_row(:,puti) = tmp_row(:,puti) + hij * coefs(:)
end if
putj = p1
if(.not. banned(puti,putj,1)) then
hij = mo_two_e_integral(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
tmp_row2(:,puti) = tmp_row2(:,puti) + hij * coefs(:)
end if
end do
mat(:,:p2-1,p2) = mat(:,:p2-1,p2) + tmp_row(:,:p2-1)
mat(:,p2,p2:) = mat(:,p2,p2:) + tmp_row(:,p2:)
mat(:,:p1-1,p1) = mat(:,:p1-1,p1) + tmp_row2(:,:p1-1)
mat(:,p1,p1:) = mat(:,p1,p1:) + tmp_row2(:,p1:)
end if
end if
deallocate(lbanned)
!! MONO
if(sp == 3) then
s1 = 1
s2 = 2
else
s1 = sp
s2 = sp
end if
do i1=1,p(0,s1)
ib = 1
if(s1 == s2) ib = i1+1
do i2=ib,p(0,s2)
p1 = p(i1,s1)
p2 = p(i2,s2)
if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
mat(:, p1, p2) = mat(:, p1, p2) + coefs(:) * hij
end do
end do
end
subroutine get_d2_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(2,N_int)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision, external :: get_phase_bi, mo_two_e_integral
integer :: i, j, tip, ma, mi, puti, putj
integer :: h1, h2, p1, p2, i1, i2
double precision :: hij, phase
integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/))
integer, parameter :: turn2(2) = (/2, 1/)
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer :: bant
bant = 1
tip = p(0,1) * p(0,2)
ma = sp
if(p(0,1) > p(0,2)) ma = 1
if(p(0,1) < p(0,2)) ma = 2
mi = mod(ma, 2) + 1
if(sp == 3) then
if(ma == 2) bant = 2
if(tip == 3) then
puti = p(1, mi)
do i = 1, 3
putj = p(i, ma)
if(banned(putj,puti,bant)) cycle
i1 = turn3(1,i)
i2 = turn3(2,i)
p1 = p(i1, ma)
p2 = p(i2, ma)
h1 = h(1, ma)
h2 = h(2, ma)
hij = (mo_two_e_integral(p1, p2, h1, h2) - mo_two_e_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
if(ma == 1) then
mat(:, putj, puti) = mat(:, putj, puti) + coefs(:) * hij
else
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end if
end do
else
h1 = h(1,1)
h2 = h(1,2)
do j = 1,2
putj = p(j, 2)
p2 = p(turn2(j), 2)
do i = 1,2
puti = p(i, 1)
if(banned(puti,putj,bant)) cycle
p1 = p(turn2(i), 1)
hij = mo_two_e_integral(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
end if
else
if(tip == 0) then
h1 = h(1, ma)
h2 = h(2, ma)
do i=1,3
puti = p(i, ma)
do j=i+1,4
putj = p(j, ma)
if(banned(puti,putj,1)) cycle
i1 = turn2d(1, i, j)
i2 = turn2d(2, i, j)
p1 = p(i1, ma)
p2 = p(i2, ma)
hij = (mo_two_e_integral(p1, p2, h1, h2) - mo_two_e_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
else if(tip == 3) then
h1 = h(1, mi)
h2 = h(1, ma)
p1 = p(1, mi)
do i=1,3
puti = p(turn3(1,i), ma)
putj = p(turn3(2,i), ma)
if(banned(puti,putj,1)) cycle
p2 = p(i, ma)
hij = mo_two_e_integral(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2,N_int)
mat(:, min(puti, putj), max(puti, putj)) = mat(:, min(puti, putj), max(puti, putj)) + coefs(:) * hij
end do
else ! tip == 4
puti = p(1, sp)
putj = p(2, sp)
if(.not. banned(puti,putj,1)) then
p1 = p(1, mi)
p2 = p(2, mi)
h1 = h(1, mi)
h2 = h(2, mi)
hij = (mo_two_e_integral(p1, p2, h1, h2) - mo_two_e_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end if
end if
end if
end

356
src/cipsi/selection_singles.irp.f Normal file
View File

@ -0,0 +1,356 @@
use bitmasks
subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,buf)
use bitmasks
use selection_types
implicit none
BEGIN_DOC
! Select determinants connected to i_det by H
END_DOC
integer, intent(in) :: i_gen
integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2)
double precision, intent(in) :: fock_diag_tmp(mo_num)
double precision, intent(in) :: E0(N_states)
type(pt2_type), intent(inout) :: pt2_data
type(selection_buffer), intent(inout) :: buf
logical, allocatable :: banned(:,:), bannedOrb(:)
double precision, allocatable :: mat(:,:,:)
integer :: i, j, k
integer :: h1,h2,s1,s2,i1,i2,ib,sp
integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2)
logical :: fullMatch, ok
do k=1,N_int
hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1))
hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2))
particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1))
particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2))
enddo
allocate(banned(mo_num,mo_num), bannedOrb(mo_num), mat(N_states, mo_num, 1))
banned = .False.
! Create lists of holes and particles
! -----------------------------------
integer :: N_holes(2), N_particles(2)
integer :: hole_list(N_int*bit_kind_size,2)
integer :: particle_list(N_int*bit_kind_size,2)
call bitstring_to_list_ab(hole , hole_list , N_holes , N_int)
call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
do sp=1,2
do i=1, N_holes(sp)
h1 = hole_list(i,sp)
call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int)
bannedOrb = .true.
do j=1,N_particles(sp)
bannedOrb(particle_list(j, sp)) = .false.
end do
call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch)
if(fullMatch) cycle
mat = 0d0
call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, mat(1,1,1))
call fill_buffer_single(i_gen, sp, h1, 0, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf)
end do
enddo
end subroutine
subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch)
use bitmasks
implicit none
integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N)
integer, intent(in) :: i_gen, N, sp
logical, intent(inout) :: banned(mo_num)
logical, intent(out) :: fullMatch
integer :: i, j, na, nb, list(3), nt
integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2)
fullMatch = .false.
do i=1,N_int
negMask(i,1) = not(mask(i,1))
negMask(i,2) = not(mask(i,2))
end do
genl : do i=1, N
nt = 0
do j=1, N_int
myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1))
myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2))
nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2))
end do
if(nt > 3) cycle
if(nt <= 2 .and. i < i_gen) then
fullMatch = .true.
return
end if
call bitstring_to_list(myMask(1,sp), list(1), na, N_int)
if(nt == 3 .and. i < i_gen) then
do j=1,na
banned(list(j)) = .true.
end do
else if(nt == 1 .and. na == 1) then
banned(list(1)) = .true.
end if
end do genl
end subroutine
subroutine splash_p(mask, sp, det, coefs, N_sel, bannedOrb, vect)
use bitmasks
implicit none
integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel)
double precision, intent(in) :: coefs(N_states, N_sel)
integer, intent(in) :: sp, N_sel
logical, intent(inout) :: bannedOrb(mo_num)
double precision, intent(inout) :: vect(N_states, mo_num)
integer :: i, j, h(0:2,2), p(0:3,2), nt
integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
integer(bit_kind) :: phasemask(N_int, 2)
do i=1,N_int
negMask(i,1) = not(mask(i,1))
negMask(i,2) = not(mask(i,2))
end do
do i=1, N_sel
nt = 0
do j=1,N_int
mobMask(j,1) = iand(negMask(j,1), det(j,1,i))
mobMask(j,2) = iand(negMask(j,2), det(j,2,i))
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
end do
if(nt > 3) cycle
do j=1,N_int
perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
end do
call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int)
call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int)
call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int)
call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int)
call get_mask_phase(psi_det_sorted(1,1,i), phasemask, N_int)
if(nt == 3) then
call get_m2(det(1,1,i), phasemask, bannedOrb, vect, mask, h, p, sp, coefs(1, i))
else if(nt == 2) then
call get_m1(det(1,1,i), phasemask, bannedOrb, vect, mask, h, p, sp, coefs(1, i))
else
call get_m0(det(1,1,i), phasemask, bannedOrb, vect, mask, h, p, sp, coefs(1, i))
end if
end do
end subroutine
subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int, 2)
logical, intent(in) :: bannedOrb(mo_num)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: vect(N_states, mo_num)
integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti
double precision :: hij
double precision, external :: get_phase_bi, mo_two_e_integral
integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer, parameter :: turn2(2) = (/2,1/)
if(h(0,sp) == 2) then
h1 = h(1, sp)
h2 = h(2, sp)
do i=1,3
puti = p(i, sp)
if(bannedOrb(puti)) cycle
p1 = p(turn3_2(1,i), sp)
p2 = p(turn3_2(2,i), sp)
hij = mo_two_e_integral(p1, p2, h1, h2) - mo_two_e_integral(p2, p1, h1, h2)
hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2)
vect(:, puti) += hij * coefs
end do
else if(h(0,sp) == 1) then
sfix = turn2(sp)
hfix = h(1,sfix)
pfix = p(1,sfix)
hmob = h(1,sp)
do j=1,2
puti = p(j, sp)
if(bannedOrb(puti)) cycle
pmob = p(turn2(j), sp)
hij = mo_two_e_integral(pfix, pmob, hfix, hmob)
hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix)
vect(:, puti) += hij * coefs
end do
else
puti = p(1,sp)
if(.not. bannedOrb(puti)) then
sfix = turn2(sp)
p1 = p(1,sfix)
p2 = p(2,sfix)
h1 = h(1,sfix)
h2 = h(2,sfix)
hij = (mo_two_e_integral(p1,p2,h1,h2) - mo_two_e_integral(p2,p1,h1,h2))
hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2)
vect(:, puti) += hij * coefs
end if
end if
end subroutine
subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int, 2)
logical, intent(in) :: bannedOrb(mo_num)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: vect(N_states, mo_num)
integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
integer :: i, hole, p1, p2, sh
logical :: ok, lbanned(mo_num)
integer(bit_kind) :: det(N_int, 2)
double precision :: hij
double precision, external :: get_phase_bi,mo_two_e_integral
lbanned = bannedOrb
sh = 1
if(h(0,2) == 1) sh = 2
hole = h(1, sh)
lbanned(p(1,sp)) = .true.
if(p(0,sp) == 2) lbanned(p(2,sp)) = .true.
!print *, "SPm1", sp, sh
p1 = p(1, sp)
if(sp == sh) then
p2 = p(2, sp)
lbanned(p2) = .true.
do i=1,hole-1
if(lbanned(i)) cycle
hij = (mo_two_e_integral(p1, p2, i, hole) - mo_two_e_integral(p2, p1, i, hole))
hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2)
vect(:,i) += hij * coefs
end do
do i=hole+1,mo_num
if(lbanned(i)) cycle
hij = (mo_two_e_integral(p1, p2, hole, i) - mo_two_e_integral(p2, p1, hole, i))
hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2)
vect(:,i) += hij * coefs
end do
call apply_particle(mask, sp, p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
vect(:, p2) += hij * coefs
else
p2 = p(1, sh)
do i=1,mo_num
if(lbanned(i)) cycle
hij = mo_two_e_integral(p1, p2, i, hole)
hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2)
vect(:,i) += hij * coefs
end do
end if
call apply_particle(mask, sp, p1, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
vect(:, p1) += hij * coefs
end subroutine
subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int, 2)
logical, intent(in) :: bannedOrb(mo_num)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: vect(N_states, mo_num)
integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
integer :: i
logical :: ok, lbanned(mo_num)
integer(bit_kind) :: det(N_int, 2)
double precision :: hij
lbanned = bannedOrb
lbanned(p(1,sp)) = .true.
do i=1,mo_num
if(lbanned(i)) cycle
call apply_particle(mask, sp, i, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
vect(:, i) += hij * coefs
end do
end subroutine
!
!subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
! use bitmasks
! use selection_types
! implicit none
!
! integer, intent(in) :: i_generator, sp, h1
! double precision, intent(in) :: vect(N_states, mo_num)
! logical, intent(in) :: bannedOrb(mo_num)
! double precision, intent(in) :: fock_diag_tmp(mo_num)
! double precision, intent(in) :: E0(N_states)
! double precision, intent(inout) :: pt2(N_states)
! type(selection_buffer), intent(inout) :: buf
! logical :: ok
! integer :: s1, s2, p1, p2, ib, istate
! integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
! double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp
! double precision, external :: diag_H_mat_elem_fock
!
!
! call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int)
!
! do p1=1,mo_num
! if(bannedOrb(p1)) cycle
! if(vect(1, p1) == 0d0) cycle
! call apply_particle(mask, sp, p1, det, ok, N_int)
!
!
! Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
! max_e_pert = 0d0
!
! do istate=1,N_states
! val = vect(istate, p1) + vect(istate, p1)
! delta_E = E0(istate) - Hii
! tmp = dsqrt(delta_E * delta_E + val * val)
! if (delta_E < 0.d0) then
! tmp = -tmp
! endif
! e_pert = 0.5d0 * ( tmp - delta_E)
! pt2(istate) += e_pert
! if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
! end do
!
! if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert)
! end do
!end subroutine
!

5
src/davidson/davidson_parallel.irp.f
View File

@ -545,11 +545,6 @@ end
integer function zmq_put_N_states_diag(zmq_to_qp_run_socket,worker_id)
use f77_zmq
implicit none

28
src/ezfio_files/00.create.bats
View File

@ -23,6 +23,34 @@ function run {
qp set mo_two_e_ints io_mo_two_e_integrals "Write"
}
@test "H2_1" {
run h2_1.xyz 1 0 cc-pvdz
}
@test "H2_3" {
run h2_3.xyz 3 0 cc-pvdz
}
@test "H3_2" {
run h3_2.xyz 2 0 cc-pvdz
}
@test "H3_4" {
run h3_4.xyz 4 0 cc-pvdz
}
@test "H4_1" {
run h4_1.xyz 1 0 cc-pvdz
}
@test "H4_3" {
run h4_3.xyz 3 0 cc-pvdz
}
@test "H4_5" {
run h4_5.xyz 5 0 cc-pvdz
}
@test "B-B" {
qp set_file b2_stretched.ezfio

115
src/fci/40.fci.bats
View File

@ -10,8 +10,8 @@ function run() {
qp set perturbation do_pt2 False
qp set determinants n_det_max 8000
qp set determinants n_states 1
qp set davidson threshold_davidson 1.e-10
qp set davidson n_states_diag 8
qp set davidson_keywords threshold_davidson 1.e-10
qp set davidson_keywords n_states_diag 8
qp run fci
energy1="$(ezfio get fci energy | tr '[]' ' ' | cut -d ',' -f 1)"
eq $energy1 $1 $thresh
@ -24,99 +24,134 @@ function run_stoch() {
qp set perturbation do_pt2 True
qp set determinants n_det_max $3
qp set determinants n_states 1
qp set davidson threshold_davidson 1.e-10
qp set davidson n_states_diag 1
qp set davidson_keywords threshold_davidson 1.e-10
qp set davidson_keywords n_states_diag 1
qp run fci
energy1="$(ezfio get fci energy_pt2 | tr '[]' ' ' | cut -d ',' -f 1)"
eq $energy1 $1 $thresh
}
@test "B-B" {
@test "H2_1" { # 1s
qp set_file h2_1.ezfio
qp set perturbation pt2_max 0.
run_stoch -1.06415255 1.e-8 10000
}
@test "H2_3" { # 1s
qp set_file h2_3.ezfio
qp set perturbation pt2_max 0.
run_stoch -0.96029881 1.e-8 10000
}
@test "H3_2" { # 3s
qp set_file h3_2.ezfio
qp set perturbation pt2_max 0.
run_stoch -1.61003132 1.e-8 10000
}
@test "H3_4" { # 2s
qp set_file h3_4.ezfio
qp set perturbation pt2_max 0.
run_stoch -1.02434843 1.e-8 10000
}
@test "H4_1" { # 13s
qp set_file h4_1.ezfio
qp set perturbation pt2_max 0.
run_stoch -2.01675062 1.e-8 10000
}
@test "H4_3" { # 10s
qp set_file h4_3.ezfio
qp set perturbation pt2_max 0.
run_stoch -1.95927626 1.e-8 10000
}
@test "H4_5" { # 3s
qp set_file h4_5.ezfio
qp set perturbation pt2_max 0.
run_stoch -1.25852765 1.e-8 10000
}
@test "B-B" { # 10s
qp set_file b2_stretched.ezfio
qp set determinants n_det_max 10000
qp set_frozen_core
run_stoch -49.14103054419 3.e-4 10000
}
@test "F2" { # 4.07m
[[ -n $TRAVIS ]] && skip
qp set_file f2.ezfio
qp set_frozen_core
run_stoch -199.304922384814 3.e-3 100000
}
@test "NH3" { # 10.6657s
@test "NH3" { # 8s
qp set_file nh3.ezfio
qp set_mo_class --core="[1-4]" --act="[5-72]"
run -56.244753429144986 3.e-4 100000
}
@test "DHNO" { # 11.4721s
@test "DHNO" { # 8s
qp set_file dhno.ezfio
qp set_mo_class --core="[1-7]" --act="[8-64]"
run -130.459020029816 3.e-4 100000
run -130.466208113547 3.e-4 100000
}
@test "HCO" { # 12.2868s
@test "HCO" { # 32s
qp set_file hco.ezfio
run -113.393356604085 1.e-3 100000
run -113.395751656985 1.e-3 100000
}
@test "H2O2" { # 12.9214s
@test "H2O2" { # 21s
qp set_file h2o2.ezfio
qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-38]"
run -151.005848404095 1.e-3 100000
}
@test "HBO" { # 13.3144s
@test "HBO" { # 18s
[[ -n $TRAVIS ]] && skip
qp set_file hbo.ezfio
run -100.213 1.5e-3 100000
run -100.214 1.5e-3 100000
}
@test "H2O" { # 11.3727s
@test "H2O" { # 16s
[[ -n $TRAVIS ]] && skip
qp set_file h2o.ezfio
run -76.2361605151999 5.e-4 100000
run -76.238051555276 5.e-4 100000
}
@test "ClO" { # 13.3755s
@test "ClO" { # 47s
[[ -n $TRAVIS ]] && skip
qp set_file clo.ezfio
run -534.546453546852 1.e-3 100000
run -534.548529710256 1.e-3 100000
}
@test "SO" { # 13.4952s
@test "SO" { # 23s
[[ -n $TRAVIS ]] && skip
qp set_file so.ezfio
run -26.015 3.e-3 100000
}
@test "H2S" { # 13.6745s
@test "H2S" { # 37s
[[ -n $TRAVIS ]] && skip
qp set_file h2s.ezfio
run -398.859577605891 5.e-4 100000
run -398.864853669111 5.e-4 100000
}
@test "OH" { # 13.865s
@test "OH" { # 12s
[[ -n $TRAVIS ]] && skip
qp set_file oh.ezfio
run -75.6121856748294 3.e-4 100000
run -75.615 1.5e-3 100000
}
@test "SiH2_3B1" { # 13.938ss
@test "SiH2_3B1" { # 10s
[[ -n $TRAVIS ]] && skip
qp set_file sih2_3b1.ezfio
run -290.0175411299477 3.e-4 100000
run -290.0206626734517 3.e-4 100000
}
@test "H3COH" { # 14.7299s
@test "H3COH" { # 33s
[[ -n $TRAVIS ]] && skip
qp set_file h3coh.ezfio
run -115.205632960026 1.e-3 100000
run -115.206784386204 1.e-3 100000
}
@test "SiH3" { # 15.99s
@test "SiH3" { # 15s
[[ -n $TRAVIS ]] && skip
qp set_file sih3.ezfio
run -5.572 1.e-3 100000
@ -132,7 +167,7 @@ function run_stoch() {
@test "ClF" { # 16.8864s
[[ -n $TRAVIS ]] && skip
qp set_file clf.ezfio
run -559.169748890031 1.5e-3 100000
run -559.174371468224 1.5e-3 100000
}
@test "SO2" { # 17.5645s
@ -170,12 +205,11 @@ function run_stoch() {
run -187.970184372047 1.6e-3 100000
}
@test "[Cu(NH3)4]2+" { # 25.0417s
[[ -n $TRAVIS ]] && skip
qp set_file cu_nh3_4_2plus.ezfio
qp set_mo_class --core="[1-24]" --act="[25-45]" --del="[46-87]"
run -1862.9869374387192 3.e-04 100000
run -1862.98320066637 3.e-04 100000
}
@test "HCN" { # 20.3273s
@ -185,3 +219,10 @@ function run_stoch() {
run -93.078 2.e-3 100000
}
@test "F2" { # 4.07m
[[ -n $TRAVIS ]] && skip
qp set_file f2.ezfio
qp set_frozen_core
run_stoch -199.304922384814 3.e-3 100000
}

32
src/hartree_fock/10.hf.bats
View File

@ -43,11 +43,39 @@ python write_pt_charges.py ${EZFIO}
qp set nuclei point_charges True
qp run scf | tee ${EZFIO}.pt_charges.out
energy="$(ezfio get hartree_fock energy)"
good=-92.76613324421798
good=-92.79920682236470
eq $energy $good $thresh
rm -rf $EZFIO
}
@test "H2_1" { # 1s
run h2_1.ezfio -1.005924963288527
}
@test "H2_3" { # 1s
run h2_3.ezfio -0.9591011604845440
}
@test "H3_2" { # 1s
run h3_2.ezfio -1.558273529860488
}
@test "H3_4" { # 1s
run h3_4.ezfio -1.0158684760025190
}
@test "H4_1" { # 1s
run h4_1.ezfio -1.932022805374405
}
@test "H4_3" { # 1s
run h4_3.ezfio -1.8948449927787350
}
@test "H4_5" { # 1s
run h4_5.ezfio -1.2408338805496990
}
@test "point charges" {
run_pt_charges
}
@ -56,6 +84,8 @@ rm -rf $EZFIO
run hcn.ezfio -92.88717500035233
}
@test "B-B" { # 3s
run b2_stretched.ezfio -48.9950585434279
}

141
src/mo_optimization/my_providers.irp.f
View File

@ -1,141 +0,0 @@
! Dimensions of MOs
BEGIN_PROVIDER [ integer, n_mo_dim ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of MOs we can build,
! with i>j
END_DOC
n_mo_dim = mo_num*(mo_num-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_core ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of core MOs we can build,
! with i>j
END_DOC
n_mo_dim_core = dim_list_core_orb*(dim_list_core_orb-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_act ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of active MOs we can build,
! with i>j
END_DOC
n_mo_dim_act = dim_list_act_orb*(dim_list_act_orb-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_inact ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of inactive MOs we can build,
! with i>j
END_DOC
n_mo_dim_inact = dim_list_inact_orb*(dim_list_inact_orb-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_virt ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of virtual MOs we can build,
! with i>j
END_DOC
n_mo_dim_virt = dim_list_virt_orb*(dim_list_virt_orb-1)/2
END_PROVIDER
! Energies/criterions
BEGIN_PROVIDER [ double precision, my_st_av_energy ]
implicit none
BEGIN_DOC
! State average CI energy
END_DOC
!call update_st_av_ci_energy(my_st_av_energy)
call state_average_energy(my_st_av_energy)
END_PROVIDER
! With all the MOs
BEGIN_PROVIDER [ double precision, my_gradient_opt, (n_mo_dim) ]
&BEGIN_PROVIDER [ double precision, my_CC1_opt ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, for all the MOs.
! - Maximal element of the gradient in absolute value
END_DOC
double precision :: norm_grad
PROVIDE mo_two_e_integrals_in_map
call gradient_opt(n_mo_dim, my_gradient_opt, my_CC1_opt, norm_grad)
END_PROVIDER
BEGIN_PROVIDER [ double precision, my_hessian_opt, (n_mo_dim, n_mo_dim) ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, for all the MOs.
! - Maximal element of the gradient in absolute value
END_DOC
double precision, allocatable :: h_f(:,:,:,:)
PROVIDE mo_two_e_integrals_in_map
allocate(h_f(mo_num, mo_num, mo_num, mo_num))
call hessian_list_opt(n_mo_dim, my_hessian_opt, h_f)
END_PROVIDER
! With the list of active MOs
! Can be generalized to any mo_class by changing the list/dimension
BEGIN_PROVIDER [ double precision, my_gradient_list_opt, (n_mo_dim_act) ]
&BEGIN_PROVIDER [ double precision, my_CC2_opt ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, only for the active MOs !
! - Maximal element of the gradient in absolute value
END_DOC
double precision :: norm_grad
PROVIDE mo_two_e_integrals_in_map !one_e_dm_mo two_e_dm_mo mo_one_e_integrals
call gradient_list_opt(n_mo_dim_act, dim_list_act_orb, list_act, my_gradient_list_opt, my_CC2_opt, norm_grad)
END_PROVIDER
BEGIN_PROVIDER [ double precision, my_hessian_list_opt, (n_mo_dim_act, n_mo_dim_act) ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, only for the active MOs !
! - Maximal element of the gradient in absolute value
END_DOC
double precision, allocatable :: h_f(:,:,:,:)
PROVIDE mo_two_e_integrals_in_map
allocate(h_f(dim_list_act_orb, dim_list_act_orb, dim_list_act_orb, dim_list_act_orb))
call hessian_list_opt(n_mo_dim_act, dim_list_act_orb, list_act, my_hessian_list_opt, h_f)
END_PROVIDER

2
src/mo_two_e_ints/cholesky.irp.f
View File

@ -27,6 +27,8 @@ BEGIN_PROVIDER [ double precision, cholesky_mo_transp, (cholesky_ao_num, mo_num,
double precision, allocatable :: buffer(:,:)
print *, 'AO->MO Transformation of Cholesky vectors .'
call set_multiple_levels_omp(.False.)
!$OMP PARALLEL PRIVATE(i,j,k,buffer)
allocate(buffer(mo_num,mo_num))
!$OMP DO SCHEDULE(static)

7
src/nuclei/nuclei.irp.f
View File

@ -206,7 +206,12 @@ BEGIN_PROVIDER [ double precision, nuclear_repulsion ]
enddo
nuclear_repulsion *= 0.5d0
if(point_charges)then
nuclear_repulsion += pt_chrg_nuclei_interaction + pt_chrg_interaction
print*,'bear nuclear repulsion = ',nuclear_repulsion
print*,'adding the interaction between the nuclein and the point charges'
print*,'to the usual nuclear repulsion '
nuclear_repulsion += pt_chrg_nuclei_interaction
print*,'new nuclear repulsion = ',nuclear_repulsion
print*,'WARNING: we do not add the interaction between the point charges themselves'
endif
end if

3
src/nuclei/point_charges.irp.f
View File

@ -205,5 +205,8 @@ BEGIN_PROVIDER [ double precision, pt_chrg_nuclei_interaction]
enddo
print*,'Interaction between point charges and nuclei'
print*,'pt_chrg_nuclei_interaction = ',pt_chrg_nuclei_interaction
if(point_charges)then
provide pt_chrg_interaction
endif
END_PROVIDER

1
src/tc_bi_ortho/slater_tc_opt.irp.f
View File

@ -1,4 +1,3 @@
! ---
subroutine provide_all_three_ints_bi_ortho()

1
src/tools/print_wf.irp.f
View File

@ -47,6 +47,7 @@ subroutine routine
do i = 1, min(N_det_print_wf,N_det)
print*,''
print*,'i = ',i
print *,psi_det_sorted(1,1,i)
call debug_det(psi_det_sorted(1,1,i),N_int)
call get_excitation_degree(psi_det_sorted(1,1,i),psi_det_sorted(1,1,1),degree,N_int)
print*,'degree = ',degree

6
src/utils/linear_algebra.irp.f
View File

@ -1831,7 +1831,7 @@ double precision, intent(in) :: tol
integer, dimension(:), allocatable :: piv
double precision, dimension(:), allocatable :: work
character, parameter :: uplo = "U"
character, parameter :: uplo = 'L'
integer :: LDA
integer :: info
integer :: k, l, rank0
@ -1848,14 +1848,14 @@ if (rank > rank0) then
end if
do k = 1, ndim
A(k+1:ndim, k) = 0.00D+0
A(k,k+1:ndim) = 0.00D+0
end do
! TODO: It should be possible to use only one vector of size (1:rank) as a buffer
! to do the swapping in-place
U(:,:) = 0.00D+0
do k = 1, ndim
l = piv(k)
U(l, 1:rank) = A(1:rank, k)
U(l, 1:rank) = A(k,1:rank)
end do
end subroutine pivoted_cholesky

16
src/utils_cc/EZFIO.cfg
View File

@ -46,17 +46,11 @@ doc: Guess used to initialize the T2 amplitudes. none -> 0, MP -> perturbation t
interface: ezfio,ocaml,provider
default: MP
[cc_write_t1]
type: logical
doc: If true, it will write on disk the T1 amplitudes at the end of the calculation.
interface: ezfio,ocaml,provider
default: False
[cc_write_t2]
type: logical
doc: If true, it will write on disk the T2 amplitudes at the end of the calculation.
interface: ezfio,ocaml,provider
default: False
[io_amplitudes]
type: Disk_access
doc: Read/Write |CCSD| amplitudes from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[cc_par_t]
type: logical

75
src/utils_cc/guess_t.irp.f
View File

@ -91,16 +91,17 @@ subroutine write_t1(nO,nV,t1)
double precision, intent(in) :: t1(nO, nV)
! internal
integer :: i,a
integer :: i,a, iunit
integer, external :: getunitandopen
if (cc_write_t1) then
open(unit=11, file=trim(ezfio_filename)//'/cc_utils/T1')
if (write_amplitudes) then
iunit = getUnitAndOpen(trim(ezfio_filename)//'/work/T1','w')
do a = 1, nV
do i = 1, nO
write(11,'(F20.12)') t1(i,a)
write(iunit,'(F20.12)') t1(i,a)
enddo
enddo
close(11)
close(iunit)
endif
end
@ -120,20 +121,21 @@ subroutine write_t2(nO,nV,t2)
double precision, intent(in) :: t2(nO, nO, nV, nV)
! internal
integer :: i,j,a,b
integer :: i,j,a,b, iunit
integer, external :: getunitandopen
if (cc_write_t2) then
open(unit=11, file=trim(ezfio_filename)//'/cc_utils/T2')
if (write_amplitudes) then
iunit = getUnitAndOpen(trim(ezfio_filename)//'/work/T2','w')
do b = 1, nV
do a = 1, nV
do j = 1, nO
do i = 1, nO
write(11,'(F20.12)') t2(i,j,a,b)
write(iunit,'(F20.12)') t2(i,j,a,b)
enddo
enddo
enddo
enddo
close(11)
close(iunit)
endif
end
@ -153,23 +155,19 @@ subroutine read_t1(nO,nV,t1)
double precision, intent(out) :: t1(nO, nV)
! internal
integer :: i,a
integer :: i,a, iunit
logical :: ok
integer, external :: getunitandopen
inquire(file=trim(ezfio_filename)//'/cc_utils/T1', exist=ok)
if (.not. ok) then
print*, 'There is no file'// trim(ezfio_filename)//'/cc_utils/T1'
print*, 'Do a first calculation with cc_write_t1 = True'
print*, 'and cc_guess_t1 /= read before setting cc_guess_t1 = read'
call abort
endif
open(unit=11, file=trim(ezfio_filename)//'/cc_utils/T1')
do a = 1, nV
do i = 1, nO
read(11,'(F20.12)') t1(i,a)
if (read_amplitudes) then
iunit = getUnitAndOpen(trim(ezfio_filename)//'/work/T1','r')
do a = 1, nV
do i = 1, nO
read(iunit,'(F20.12)') t1(i,a)
enddo
enddo
enddo
close(11)
close(iunit)
endif
end
@ -188,26 +186,23 @@ subroutine read_t2(nO,nV,t2)
double precision, intent(out) :: t2(nO, nO, nV, nV)
! internal
integer :: i,j,a,b
integer :: i,j,a,b, iunit
logical :: ok
inquire(file=trim(ezfio_filename)//'/cc_utils/T1', exist=ok)
if (.not. ok) then
print*, 'There is no file'// trim(ezfio_filename)//'/cc_utils/T1'
print*, 'Do a first calculation with cc_write_t2 = True'
print*, 'and cc_guess_t2 /= read before setting cc_guess_t2 = read'
call abort
endif
open(unit=11, file=trim(ezfio_filename)//'/cc_utils/T2')
do b = 1, nV
do a = 1, nV
do j = 1, nO
do i = 1, nO
read(11,'(F20.12)') t2(i,j,a,b)
integer, external :: getunitandopen
if (read_amplitudes) then
iunit = getUnitAndOpen(trim(ezfio_filename)//'/work/T2','r')
do b = 1, nV
do a = 1, nV
do j = 1, nO
do i = 1, nO
read(iunit,'(F20.12)') t2(i,j,a,b)
enddo
enddo
enddo
enddo
enddo
close(11)
close(iunit)
endif
end

2
src/utils_cc/org/phase.org
View File

@ -137,6 +137,7 @@ subroutine get_excitation_general(det1,det2,degree,n,list_anni,list_crea,phase,N
do j = 1, 2
k = 1
do i = 1, n1(j)
if (k > n_anni(j)) exit
if (l1(i,j) /= list_anni(k,j)) cycle
pos_anni(k,j) = i
k = k + 1
@ -147,6 +148,7 @@ subroutine get_excitation_general(det1,det2,degree,n,list_anni,list_crea,phase,N
do j = 1, 2
k = 1
do i = 1, n2(j)
if (k > n_crea(j)) exit
if (l2(i,j) /= list_crea(k,j)) cycle
pos_crea(k,j) = i
k = k + 1

2
src/utils_cc/phase.irp.f
View File

@ -96,6 +96,7 @@ subroutine get_excitation_general(det1,det2,degree,n,list_anni,list_crea,phase,N
do j = 1, 2
k = 1
do i = 1, n1(j)
if (k > n_anni(j)) exit
if (l1(i,j) /= list_anni(k,j)) cycle
pos_anni(k,j) = i
k = k + 1
@ -106,6 +107,7 @@ subroutine get_excitation_general(det1,det2,degree,n,list_anni,list_crea,phase,N
do j = 1, 2
k = 1
do i = 1, n2(j)
if (k > n_crea(j)) exit
if (l2(i,j) /= list_crea(k,j)) cycle
pos_crea(k,j) = i
k = k + 1

6
tests/input/h2_1.xyz Normal file
View File

@ -0,0 +1,6 @@
2
H2
H 0.0 0.0 -0.74
H 0.0 0.0 0.74

6
tests/input/h2_3.xyz Normal file
View File

@ -0,0 +1,6 @@
2
H2
H 0.0 0.0 -0.74
H 0.0 0.0 0.74

7
tests/input/h3_2.xyz Normal file
View File

@ -0,0 +1,7 @@
3
h3
H 0.0 0.0 -0.74
H 0.0 0.0 0.74
H 0.0 0.0 0.0

7
tests/input/h3_4.xyz Normal file
View File

@ -0,0 +1,7 @@
3
h3
H 0.0 0.0 -0.74
H 0.0 0.0 0.74
H 0.0 0.0 0.0

7
tests/input/h4_1.xyz Normal file
View File

@ -0,0 +1,7 @@
4
h4
H 0.0 0.0 -0.74
H 0.0 0.0 0.74
H 0.0 0.74 0.0
H 0.0 0.0 0.0

7
tests/input/h4_3.xyz Normal file
View File

@ -0,0 +1,7 @@
4
h4
H 0.0 0.0 -0.74
H 0.0 0.0 0.74
H 0.0 0.74 0.0
H 0.0 0.0 0.0

7
tests/input/h4_5.xyz Normal file
View File

@ -0,0 +1,7 @@
4
h4
H 0.0 0.0 -0.74
H 0.0 0.0 0.74
H 0.0 0.74 0.0
H 0.0 0.0 0.0