10
0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-30 16:15:51 +01:00
quantum_package/plugins/Perturbation/perturbation.template.f

261 lines
10 KiB
Fortran
Raw Normal View History

2014-05-18 22:46:38 +02:00
BEGIN_SHELL [ /usr/bin/env python ]
import perturbation
END_SHELL
2015-12-16 15:05:57 +01:00
2016-04-01 23:33:58 +02:00
subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint,key_mask,fock_diag_tmp,electronic_energy)
2014-05-18 22:46:38 +02:00
implicit none
BEGIN_DOC
! Applly pertubration ``$PERT`` to the buffer of determinants generated in the H_apply
! routine.
END_DOC
2014-05-27 17:30:44 +02:00
integer, intent(in) :: Nint, N_st, buffer_size, i_generator
2014-05-18 22:46:38 +02:00
integer(bit_kind), intent(in) :: buffer(Nint,2,buffer_size)
2015-11-19 14:38:41 +01:00
integer(bit_kind),intent(in) :: key_mask(Nint,2)
double precision, intent(in) :: fock_diag_tmp(2,0:mo_tot_num)
2016-04-01 23:33:58 +02:00
double precision, intent(in) :: electronic_energy(N_st)
2014-05-21 16:37:54 +02:00
double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st)
double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st)
2014-05-28 23:12:00 +02:00
double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st)
2016-02-19 00:20:28 +01:00
integer :: i,k,l, c_ref, ni, ex
2014-06-02 15:18:45 +02:00
integer, external :: connected_to_ref
2014-06-02 16:42:33 +02:00
logical, external :: is_in_wavefunction
2014-05-18 22:46:38 +02:00
2015-11-27 15:20:15 +01:00
integer(bit_kind), allocatable :: minilist(:,:,:)
integer, allocatable :: idx_minilist(:)
integer :: N_minilist
2015-11-19 14:38:41 +01:00
2015-11-27 15:20:15 +01:00
integer(bit_kind), allocatable :: minilist_gen(:,:,:)
2015-11-19 20:57:44 +01:00
integer :: N_minilist_gen
logical :: fullMatch
2015-11-19 21:20:43 +01:00
logical, external :: is_connected_to
2015-12-16 15:05:57 +01:00
2016-01-01 11:47:17 +01:00
integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:)
integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:)
2015-12-16 15:05:57 +01:00
integer :: mobiles(2), smallerlist
2015-12-18 14:29:45 +01:00
2016-01-01 11:47:17 +01:00
integer(bit_kind), allocatable :: microlist_gen(:,:,:)
integer, allocatable :: idx_microlist_gen(:), N_microlist_gen(:), ptr_microlist_gen(:)
2015-12-18 14:29:45 +01:00
2015-11-27 15:20:15 +01:00
allocate( minilist(Nint,2,N_det_selectors), &
minilist_gen(Nint,2,N_det_generators), &
2015-12-16 15:05:57 +01:00
idx_minilist(N_det_selectors))
2015-11-19 14:38:41 +01:00
2015-11-19 20:57:44 +01:00
2014-05-18 22:46:38 +02:00
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (buffer_size >= 0)
ASSERT (minval(sum_norm_pert) >= 0.d0)
ASSERT (N_st > 0)
2015-11-19 14:38:41 +01:00
2015-12-16 16:41:22 +01:00
2015-11-19 20:57:44 +01:00
call create_minilist_find_previous(key_mask, psi_det_generators, miniList_gen, i_generator-1, N_minilist_gen, fullMatch, Nint)
2015-12-16 15:05:57 +01:00
2015-11-19 20:57:44 +01:00
if(fullMatch) then
2015-11-27 15:20:15 +01:00
deallocate( minilist, minilist_gen, idx_minilist )
2015-11-19 20:57:44 +01:00
return
end if
2016-02-19 00:20:28 +01:00
2015-12-17 22:06:57 +01:00
call create_minilist(key_mask, psi_selectors, minilist, idx_miniList, N_det_selectors, N_minilist, Nint)
2016-01-01 11:47:17 +01:00
allocate( microlist(Nint,2,N_minilist*4), &
idx_microlist(N_minilist*4), &
ptr_microlist(0:mo_tot_num*2+1), &
2015-12-17 22:06:57 +01:00
N_microlist(0:mo_tot_num*2) )
2015-12-16 15:05:57 +01:00
2016-01-01 11:47:17 +01:00
allocate( microlist_gen(Nint,2,N_minilist_gen*4), &
idx_microlist_gen(N_minilist_gen*4 ), &
ptr_microlist_gen(0:mo_tot_num*2+1), &
2015-12-18 14:29:45 +01:00
N_microlist_gen(0:mo_tot_num*2) )
2015-12-16 16:41:22 +01:00
if(key_mask(1,1) /= 0) then
2016-01-01 11:47:17 +01:00
call create_microlist(minilist, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint)
call create_microlist(minilist_gen, N_minilist_gen, key_mask, microlist_gen, idx_microlist_gen, N_microlist_gen,ptr_microlist_gen,Nint)
allocate(microlist_zero(Nint,2,N_minilist))
allocate(idx_microlist_zero(N_minilist))
2015-12-18 13:40:03 +01:00
do i=0,mo_tot_num*2
2016-02-19 00:20:28 +01:00
do k=ptr_microlist(i),ptr_microlist(i+1)-1
idx_microlist(k) = idx_minilist(idx_microlist(k))
end do
2015-12-16 16:41:22 +01:00
end do
2016-01-01 11:47:17 +01:00
if(N_microlist(0) > 0) then
2016-02-19 00:20:28 +01:00
! TODO OLD
! microlist_zero(:,:,1:N_microlist(0)) = microlist(:,:,1:N_microlist(0))
! idx_microlist_zero(1:N_microlist(0)) = idx_microlist(1:N_microlist(0))
! TODO OLD
ASSERT (N_microlist(0) <= N_minilist)
do l=1,N_microlist(0)
do k=1,Nint
microlist_zero(k,1,l) = microlist(k,1,l)
microlist_zero(k,2,l) = microlist(k,2,l)
enddo
idx_microlist_zero(l) = idx_microlist(l)
enddo
2016-01-01 11:47:17 +01:00
end if
2015-12-16 16:41:22 +01:00
end if
2015-11-19 20:57:44 +01:00
2015-11-24 11:40:49 +01:00
do i=1,buffer_size
2015-11-19 14:38:41 +01:00
2015-07-29 18:27:07 +02:00
if (is_in_wavefunction(buffer(1,1,i),Nint)) then
2014-09-06 00:51:55 +02:00
cycle
endif
2015-12-16 16:41:22 +01:00
2015-12-18 14:29:45 +01:00
if(key_mask(1,1) /= 0) then
2016-02-19 00:20:28 +01:00
call getMobiles(buffer(1,1,i), key_mask, mobiles, Nint)
2015-12-16 16:41:22 +01:00
if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then
smallerlist = mobiles(1)
else
smallerlist = mobiles(2)
end if
2015-12-18 12:07:49 +01:00
2016-01-01 11:47:17 +01:00
if(N_microlist_gen(smallerlist) > 0) then
2016-02-19 00:20:28 +01:00
! TODO OLD
! if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,ptr_microlist_gen(smallerlist):ptr_microlist_gen(smallerlist+1)-1), Nint, N_microlist_gen(smallerlist))) then
! TODO OLD
ASSERT (ptr_microlist_gen(smallerlist) <= N_minilist_gen*4)
if(is_connected_to(buffer(1,1,i), microlist_gen(1,1,ptr_microlist_gen(smallerlist)), Nint, N_microlist_gen(smallerlist))) then
2015-12-18 14:29:45 +01:00
cycle
end if
end if
2016-01-01 11:47:17 +01:00
if(N_microlist_gen(0) > 0) then
2016-02-19 00:20:28 +01:00
! TODO OLD
! if(is_connected_to(buffer(1,1,i), microlist_gen(:,:,1:ptr_microlist_gen(1)-1), Nint, N_microlist_gen(0))) then
! TODO OLD
if(is_connected_to(buffer(1,1,i), microlist_gen(1,1,1), Nint, N_microlist_gen(0))) then
2016-01-01 11:47:17 +01:00
cycle
end if
2015-12-18 14:29:45 +01:00
end if
2015-12-18 12:07:49 +01:00
if(N_microlist(smallerlist) > 0) then
2016-02-19 00:20:28 +01:00
! TODO OLD
! microlist_zero(:,:,ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = microlist(:,:,ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
! idx_microlist_zero(ptr_microlist(1):ptr_microlist(1)+N_microlist(smallerlist)-1) = idx_microlist(ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
! TODO OLD
ASSERT ( ptr_microlist(1)+N_microlist(smallerlist)-1 <= N_minilist )
ASSERT ( ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 <= N_minilist*4 )
do l=0, N_microlist(smallerlist)-1
do k=1,Nint
microlist_zero(k,1,ptr_microlist(1)+l) = microlist(k,1,ptr_microlist(smallerlist)+l)
microlist_zero(k,2,ptr_microlist(1)+l) = microlist(k,2,ptr_microlist(smallerlist)+l)
enddo
idx_microlist_zero(ptr_microlist(1)+l) = idx_microlist(ptr_microlist(smallerlist)+l)
enddo
2015-12-18 12:07:49 +01:00
end if
2016-04-01 23:33:58 +02:00
call pt2_$PERT(electronic_energy,psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, &
2016-02-19 00:20:28 +01:00
c_pert,e_2_pert,H_pert_diag,Nint,N_microlist(smallerlist)+N_microlist(0), &
n_st,microlist_zero,idx_microlist_zero,N_microlist(smallerlist)+N_microlist(0))
2015-12-17 22:06:57 +01:00
else
2016-02-19 00:20:28 +01:00
ASSERT (N_minilist_gen <= N_det_generators)
2015-12-18 14:29:45 +01:00
if(is_connected_to(buffer(1,1,i), miniList_gen, Nint, N_minilist_gen)) then
cycle
end if
2016-04-01 23:33:58 +02:00
call pt2_$PERT(electronic_energy,psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, &
2015-12-17 22:06:57 +01:00
c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist)
2015-12-16 15:05:57 +01:00
end if
2016-04-01 23:33:58 +02:00
! call pt2_$PERT(electronic_energy,psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, &
2015-12-16 15:05:57 +01:00
! c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist)
2015-03-19 21:14:52 +01:00
do k = 1,N_st
2015-11-24 11:40:49 +01:00
e_2_pert_buffer(k,i) = e_2_pert(k)
coef_pert_buffer(k,i) = c_pert(k)
sum_norm_pert(k) = sum_norm_pert(k) + c_pert(k) * c_pert(k)
sum_e_2_pert(k) = sum_e_2_pert(k) + e_2_pert(k)
sum_H_pert_diag(k) = sum_H_pert_diag(k) + H_pert_diag(k)
2015-03-19 21:14:52 +01:00
enddo
2015-11-24 11:40:49 +01:00
enddo
2016-02-19 00:20:28 +01:00
deallocate( minilist, minilist_gen, idx_minilist, &
microlist, idx_microlist, N_microlist,ptr_microlist, &
microlist_gen, idx_microlist_gen,N_microlist_gen,ptr_microlist_gen )
2015-03-19 21:14:52 +01:00
end
2016-04-01 23:33:58 +02:00
subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint,key_mask,fock_diag_tmp,electronic_energy)
2015-03-19 21:14:52 +01:00
implicit none
BEGIN_DOC
! Applly pertubration ``$PERT`` to the buffer of determinants generated in the H_apply
! routine.
END_DOC
integer, intent(in) :: Nint, N_st, buffer_size, i_generator
integer(bit_kind), intent(in) :: buffer(Nint,2,buffer_size)
2015-11-24 17:46:31 +01:00
integer(bit_kind),intent(in) :: key_mask(Nint,2)
double precision, intent(in) :: fock_diag_tmp(2,0:mo_tot_num)
2016-04-01 23:33:58 +02:00
double precision, intent(in) :: electronic_energy(N_st)
2015-03-19 21:14:52 +01:00
double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st)
double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st)
double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st)
2015-11-24 17:46:31 +01:00
integer :: i,k, c_ref, ni, ex
2015-03-19 21:14:52 +01:00
integer, external :: connected_to_ref_by_mono
logical, external :: is_in_wavefunction
2015-11-27 15:20:15 +01:00
integer(bit_kind), allocatable :: minilist(:,:,:)
integer, allocatable :: idx_minilist(:)
integer :: N_minilist
2015-11-24 17:46:31 +01:00
2015-11-27 15:20:15 +01:00
integer(bit_kind), allocatable :: minilist_gen(:,:,:)
2015-11-24 17:46:31 +01:00
integer :: N_minilist_gen
logical :: fullMatch
logical, external :: is_connected_to
2015-11-27 15:20:15 +01:00
allocate( minilist(Nint,2,N_det_selectors), &
minilist_gen(Nint,2,N_det_generators), &
idx_minilist(N_det_selectors) )
2015-11-24 17:46:31 +01:00
2015-03-19 21:14:52 +01:00
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (buffer_size >= 0)
ASSERT (minval(sum_norm_pert) >= 0.d0)
ASSERT (N_st > 0)
2015-11-24 17:46:31 +01:00
call create_minilist(key_mask, psi_selectors, miniList, idx_miniList, N_det_selectors, N_minilist, Nint)
call create_minilist_find_previous(key_mask, psi_det_generators, miniList_gen, i_generator-1, N_minilist_gen, fullMatch, Nint)
if(fullMatch) then
2015-11-27 15:20:15 +01:00
deallocate( minilist, minilist_gen, idx_minilist )
2015-11-24 17:46:31 +01:00
return
end if
do i=1,buffer_size
c_ref = connected_to_ref_by_mono(buffer(1,1,i),psi_det_generators,Nint,i_generator,N_det)
2014-09-06 00:51:55 +02:00
2015-03-19 21:14:52 +01:00
if (c_ref /= 0) then
cycle
endif
2015-07-29 18:27:07 +02:00
if (is_in_wavefunction(buffer(1,1,i),Nint)) then
2015-03-19 21:14:52 +01:00
cycle
endif
2016-04-01 23:33:58 +02:00
call pt2_$PERT(electronic_energy,psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, &
2015-11-24 17:46:31 +01:00
c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist)
2014-05-18 22:46:38 +02:00
do k = 1,N_st
2015-11-24 17:46:31 +01:00
e_2_pert_buffer(k,i) = e_2_pert(k)
coef_pert_buffer(k,i) = c_pert(k)
sum_norm_pert(k) = sum_norm_pert(k) + c_pert(k) * c_pert(k)
sum_e_2_pert(k) = sum_e_2_pert(k) + e_2_pert(k)
sum_H_pert_diag(k) = sum_H_pert_diag(k) + H_pert_diag(k)
2014-05-18 22:46:38 +02:00
enddo
2015-11-24 17:46:31 +01:00
enddo
2015-11-27 15:20:15 +01:00
deallocate( minilist, minilist_gen, idx_minilist )
2014-05-18 22:46:38 +02:00
end