2014-05-18 22:46:38 +02:00
BEGIN _ SHELL [ / usr / bin / env python ]
impor t perturbation
END_S H ELL
2015-12-16 15:05:57 +01:00
2015-11-24 17:01:09 +01:00
subro u tine 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)
2014-05-18 22:46:38 +02:00
imp l icit none
BEG I N_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
int e ger , intent ( in ) :: Nint , N_st , buffer_size , i_generator
2014-05-18 22:46:38 +02:00
int e ger ( bit_kind ) , intent ( in ) :: buffer ( Nint , 2 , buffer_size )
2015-11-19 14:38:41 +01:00
int e ger ( bit_kind ) , intent ( in ) :: key_mask ( Nint , 2 )
2015-11-24 17:01:09 +01:00
dou b le precision , intent ( in ) :: fock_diag_tmp ( 2 , 0 : mo_tot_num )
2014-05-21 16:37:54 +02:00
dou b le precision , intent ( inout ) :: sum_norm_pert ( N_st ) , sum_e_2_pert ( N_ st)
dou b le 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
dou b le precision :: c_pert ( N_st ) , e_2_pert ( N_st ) , H_per t_diag(N_st)
2015-11-19 14:38:41 +01:00
int e ger :: i , k , c_ref , ni , ex
2014-06-02 15:18:45 +02:00
int e ger , external :: connected_to_ref
2014-06-02 16:42:33 +02:00
log i cal , external :: is_in_wavefunction
2014-05-18 22:46:38 +02:00
2015-11-27 15:20:15 +01:00
int e ger ( bit_kind ) , allocatable :: minilist ( : , : , : )
int e ger , allocatable :: idx_minilist ( : )
int e ger :: N_minilist
2015-11-19 14:38:41 +01:00
2015-11-27 15:20:15 +01:00
int e ger ( bit_kind ) , allocatable :: minilist_gen ( : , : , : )
2015-11-19 20:57:44 +01:00
int e ger :: N_minilist_gen
log i cal :: fullMatch
2015-11-19 21:20:43 +01:00
log i cal , external :: is_connected_to
2015-12-16 15:05:57 +01:00
2016-01-01 11:47:17 +01:00
int e ger ( bit_kind ) , allocatable :: microlist ( : , : , : ) , microlist_zero ( : , : ,:)
int e ger , allocatable :: idx_microlist ( : ) , N_microlist ( : ) , pt r_microlist(:), idx_microlist_zero(:)
2015-12-16 15:05:57 +01:00
int e ger :: mobiles ( 2 ) , smallerlist
2015-12-18 14:29:45 +01:00
2016-01-01 11:47:17 +01:00
int e ger ( bit_kind ) , allocatable :: microlist_gen ( : , : , : )
int e ger , allocatable :: idx_microlist_gen ( : ) , N_microlist_ge n(:), ptr_microlist_gen(:)
2015-12-18 14:29:45 +01:00
2015-11-27 15:20:15 +01:00
all o cate ( 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
ASS E RT ( Nint > 0 )
ASS E RT ( Nint == N_int )
ASS E RT ( buffer_size > = 0 )
ASS E RT ( minval ( sum_norm_pert ) > = 0.d0 )
ASS E RT ( 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
cal l create_minilist_find_previous ( key_mask , psi_det_generators , miniL ist_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( f ullMatch ) then
2015-11-27 15:20:15 +01:00
d e allocate ( minilist , minilist_gen , idx_minilist )
2015-11-19 20:57:44 +01:00
r e turn
end if
2015-12-17 22:06:57 +01:00
cal l create_minilist ( key_mask , psi_selectors , minilist , idx_miniList , N_det_selectors, N_minilist, Nint)
2016-01-01 11:47:17 +01:00
all o cate ( 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
all o cate ( 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( k ey_mask ( 1 , 1 ) / = 0 ) then
2016-01-01 11:47:17 +01:00
c a ll create_microlist ( minilist , N_minilist , key_mask , microlist , idx _microlist, N_microlist, ptr_microlist, Nint)
c a ll create_microlist ( minilist_gen , N_minilist_gen , key_mask , microl ist_gen, idx_microlist_gen, N_microlist_gen,ptr_microlist_gen,Nint)
a l locate ( microlist_zero ( Nint , 2 , N_minilist ) )
a l locate ( idx_microlist_zero ( N_minilist ) )
2015-12-18 13:40:03 +01:00
d o i = 0 , mo_tot_num * 2
2016-01-01 11:47:17 +01:00
d o k = ptr_microlist ( i ) , ptr_microlist ( i + 1 ) - 1
idx_microlist ( k ) = idx_minilist ( idx_microlist ( k ) )
2015-12-16 16:41:22 +01:00
e n d do
e n d do
2016-01-01 11:47:17 +01:00
i f ( N_microlist ( 0 ) > 0 ) then
microlist_zero ( : , : , 1 : N_microlist ( 0 ) ) = microlist ( : , : , 1 : N_microlist (0))
idx_microlist_zero ( 1 : N_microlist ( 0 ) ) = idx_microlist ( 1 : N_microlist (0))
e n d 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
i f ( is_in_wavefunction ( buffer ( 1 , 1 , i ) , Nint ) ) then
2014-09-06 00:51:55 +02:00
cycle
e n dif
2015-12-16 16:41:22 +01:00
2015-12-18 14:29:45 +01:00
i f ( key_mask ( 1 , 1 ) / = 0 ) then
call getMobiles ( buffer ( : , : , 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
if ( is_connected_to ( buffer ( 1 , 1 , i ) , microlist_gen ( : , : , ptr_microlis t_gen(smallerlist):ptr_microlist_gen(smallerlist+1)-1), 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
if ( is_connected_to ( buffer ( 1 , 1 , i ) , microlist_gen ( : , : , 1 : ptr_microl ist_gen(1)-1), Nint, N_microlist_gen(0))) then
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-01-01 11:47:17 +01:00
microlist_zero ( : , : , ptr_microlist ( 1 ) : ptr_microlist ( 1 ) + N_microlis t(smallerlist)-1) = microlist(:,:,ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
idx_microlist_zero ( ptr_microlist ( 1 ) : ptr_microlist ( 1 ) + N_microlis t(smallerlist)-1) = idx_microlist(ptr_microlist(smallerlist):ptr_microlist(smallerlist+1)-1)
2015-12-30 11:35:06 +01:00
! call merdge(microlist(:,:,:,smallerlist), idx_microlist(:,smallerlist), N_microlist(smallerlist), microlist(:,:,:,0), idx_microlist(:,0), N_microlist(0))
2015-12-18 12:07:49 +01:00
end if
2015-12-16 16:41:22 +01:00
call pt2_$PERT ( psi_det_generators ( 1 , 1 , i_generator ) , buffer ( 1 , 1 , i ) , fock_diag_tmp, &
2016-01-01 11:47:17 +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
e l se
2015-12-18 14:29:45 +01:00
if ( is_connected_to ( buffer ( 1 , 1 , i ) , miniList_gen , Nint , N_minilist_g en)) then
cycle
end if
2015-12-17 22:06:57 +01:00
call pt2_$PERT ( psi_det_generators ( 1 , 1 , i_generator ) , buffer ( 1 , 1 , i ) , fock_diag_tmp, &
c_pert , e_2_pert , H_pert_diag , Nint , N_minilist , n_st , minilist , idx_mi nilist,N_minilist)
2015-12-16 15:05:57 +01:00
e n d if
! call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, &
! 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
d o 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
e n ddo
2015-11-24 11:40:49 +01:00
end d o
2015-11-27 15:20:15 +01:00
dea l locate ( minilist , minilist_gen , idx_minilist )
2016-01-03 10:14:43 +01:00
dea l locate ( microlist , idx_microlist , N_microlist , ptr_microlist )
dea l locate ( microlist_gen , idx_microlist_gen , N_microlist_gen , ptr_micro list_gen )
2015-03-19 21:14:52 +01:00
end
2015-11-24 17:46:31 +01:00
subro u tine 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)
2015-03-19 21:14:52 +01:00
imp l icit none
BEG I N_DOC
! Applly pertubration ``$PERT`` to the buffer of determinants generated in the H_apply
! routine.
END _ DOC
int e ger , intent ( in ) :: Nint , N_st , buffer_size , i_generator
int e ger ( bit_kind ) , intent ( in ) :: buffer ( Nint , 2 , buffer_size )
2015-11-24 17:46:31 +01:00
int e ger ( bit_kind ) , intent ( in ) :: key_mask ( Nint , 2 )
dou b le precision , intent ( in ) :: fock_diag_tmp ( 2 , 0 : mo_tot_num )
2015-03-19 21:14:52 +01:00
dou b le precision , intent ( inout ) :: sum_norm_pert ( N_st ) , sum_e_2_pert ( N_ st)
dou b le precision , intent ( inout ) :: coef_pert_buffer ( N_st , buffer_size ) , e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st)
dou b le precision :: c_pert ( N_st ) , e_2_pert ( N_st ) , H_per t_diag(N_st)
2015-11-24 17:46:31 +01:00
int e ger :: i , k , c_ref , ni , ex
2015-03-19 21:14:52 +01:00
int e ger , external :: connected_to_ref_by_mono
log i cal , external :: is_in_wavefunction
2015-11-27 15:20:15 +01:00
int e ger ( bit_kind ) , allocatable :: minilist ( : , : , : )
int e ger , allocatable :: idx_minilist ( : )
int e ger :: N_minilist
2015-11-24 17:46:31 +01:00
2015-11-27 15:20:15 +01:00
int e ger ( bit_kind ) , allocatable :: minilist_gen ( : , : , : )
2015-11-24 17:46:31 +01:00
int e ger :: N_minilist_gen
log i cal :: fullMatch
log i cal , external :: is_connected_to
2015-11-27 15:20:15 +01:00
all o cate ( 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
ASS E RT ( Nint > 0 )
ASS E RT ( Nint == N_int )
ASS E RT ( buffer_size > = 0 )
ASS E RT ( minval ( sum_norm_pert ) > = 0.d0 )
ASS E RT ( N_st > 0 )
2015-11-24 17:46:31 +01:00
cal l create_minilist ( key_mask , psi_selectors , miniList , idx_miniList , N_det_selectors, N_minilist, Nint)
cal l create_minilist_find_previous ( key_mask , psi_det_generators , miniL ist_gen, i_generator-1, N_minilist_gen, fullMatch, Nint)
if( f ullMatch ) then
2015-11-27 15:20:15 +01:00
d e allocate ( minilist , minilist_gen , idx_minilist )
2015-11-24 17:46:31 +01:00
r e turn
end if
do i = 1 , buffer_size
2015-04-02 10:26:45 +02:00
c _ ref = connected_to_ref_by_mono ( buffer ( 1 , 1 , i ) , psi_det_generators , Ni nt,i_generator,N_det)
2014-09-06 00:51:55 +02:00
2015-03-19 21:14:52 +01:00
i f ( c_ref / = 0 ) then
cycle
e n dif
2015-07-29 18:27:07 +02:00
i f ( is_in_wavefunction ( buffer ( 1 , 1 , i ) , Nint ) ) then
2015-03-19 21:14:52 +01:00
cycle
e n dif
2015-11-24 17:46:31 +01:00
c a ll pt2_$PERT ( psi_det_generators ( 1 , 1 , i_generator ) , buffer ( 1 , 1 , i ) , fo ck_diag_tmp, &
c_pert , e_2_pert , H_pert_diag , Nint , N_minilist , n_st , minilist , idx_m inilist,N_minilist)
2014-05-18 22:46:38 +02:00
d o 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
e n ddo
2015-11-24 17:46:31 +01:00
end d o
2015-11-27 15:20:15 +01:00
dea l locate ( minilist , minilist_gen , idx_minilist )
2014-05-18 22:46:38 +02:00
end