mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-11-07 22:53:52 +01:00
82 lines
3.0 KiB
Fortran
82 lines
3.0 KiB
Fortran
subroutine $subroutine($params_main)
|
|
implicit none
|
|
use omp_lib
|
|
use bitmasks
|
|
BEGIN_DOC
|
|
! Calls H_apply on the |HF| determinant and selects all connected single and double
|
|
! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
|
|
END_DOC
|
|
|
|
$decls_main
|
|
|
|
integer :: i_generator
|
|
double precision :: wall_0, wall_1
|
|
integer(bit_kind), allocatable :: mask(:,:,:)
|
|
integer :: ispin, k
|
|
integer :: iproc
|
|
double precision, allocatable :: fock_diag_tmp(:,:)
|
|
|
|
$initialization
|
|
PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators
|
|
|
|
|
|
call wall_time(wall_0)
|
|
|
|
iproc = 0
|
|
allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_num+1) )
|
|
do i_generator=1,N_det_generators
|
|
|
|
! Compute diagonal of the Fock matrix
|
|
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
|
|
|
|
! Create bit masks for holes and particles
|
|
do ispin=1,2
|
|
do k=1,N_int
|
|
mask(k,ispin,s_hole) = &
|
|
iand(generators_bitmask(k,ispin,s_hole), &
|
|
psi_det_generators(k,ispin,i_generator) )
|
|
mask(k,ispin,s_part) = &
|
|
iand(generators_bitmask(k,ispin,s_part), &
|
|
not(psi_det_generators(k,ispin,i_generator)) )
|
|
mask(k,ispin,d_hole1) = &
|
|
iand(generators_bitmask(k,ispin,d_hole1), &
|
|
psi_det_generators(k,ispin,i_generator) )
|
|
mask(k,ispin,d_part1) = &
|
|
iand(generators_bitmask(k,ispin,d_part1), &
|
|
not(psi_det_generators(k,ispin,i_generator)) )
|
|
mask(k,ispin,d_hole2) = &
|
|
iand(generators_bitmask(k,ispin,d_hole2), &
|
|
psi_det_generators(k,ispin,i_generator) )
|
|
mask(k,ispin,d_part2) = &
|
|
iand(generators_bitmask(k,ispin,d_part2), &
|
|
not(psi_det_generators(k,ispin,i_generator)) )
|
|
enddo
|
|
enddo
|
|
if($do_double_excitations)then
|
|
call $subroutine_diexc(psi_det_generators(1,1,i_generator), &
|
|
psi_det_generators(1,1,1), &
|
|
mask(1,1,d_hole1), mask(1,1,d_part1), &
|
|
mask(1,1,d_hole2), mask(1,1,d_part2), &
|
|
fock_diag_tmp, i_generator, iproc $params_post)
|
|
endif
|
|
if($do_mono_excitations)then
|
|
call $subroutine_monoexc(psi_det_generators(1,1,i_generator), &
|
|
mask(1,1,s_hole ), mask(1,1,s_part ), &
|
|
fock_diag_tmp, i_generator, iproc $params_post)
|
|
endif
|
|
call wall_time(wall_1)
|
|
$printout_always
|
|
if (wall_1 - wall_0 > 2.d0) then
|
|
$printout_now
|
|
wall_0 = wall_1
|
|
endif
|
|
enddo
|
|
|
|
deallocate( mask, fock_diag_tmp )
|
|
|
|
$copy_buffer
|
|
$generate_psi_guess
|
|
|
|
end
|
|
|