mirror of
https://github.com/LCPQ/quantum_package
synced 2024-07-03 09:55:59 +02:00
Squashed commit of the following:
commit 96715abd7bc0645b994fc4fff1c764e7bec3042e
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Thu Sep 6 12:08:34 2018 +0200
Tasks
commit e43b1e2faff5ad1ec4ecd2eb99e8d86e0000a9a2
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Thu Sep 6 11:47:02 2018 +0200
Fixed print
commit c498c8944b5695b953909711a2e9a542e1bc6015
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Thu Sep 6 11:11:51 2018 +0200
PT2 and shiftedBk fixed
commit 965cf0361d54df096c9bfca93f9d50ecd946c198
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Wed Sep 5 18:48:59 2018 +0200
Shifted Bk multistate broken
commit 87ef641b65a122fa1256605cbe098c1a0de04bc0
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Wed Sep 5 17:23:38 2018 +0200
PT2 fixed
commit a2adb533bcaf96191a24ff5fcef86cd14ac00697
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Wed Sep 5 16:55:05 2018 +0200
Working on PT2 (broken)
commit 33f52991b65ac42ced5521ef0e713df765268860
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Wed Sep 5 12:13:23 2018 +0200
Fixed missing argument
commit 712bf75f76421880299dc65b30acfda3d531f709
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Wed Sep 5 11:42:31 2018 +0200
Fixed floating invalid in PT2
commit cf2412ebd99f9acf573a5180603611f1c3e35155
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Wed Sep 5 11:34:37 2018 +0200
n_states_diag >= n_states
commit bb415435e4d9be72a285ec789c3d63046a9173e4
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Wed Sep 5 11:23:41 2018 +0200
Fixed final print
commit f2d339cf7b
Merge: cfa8e1dc 52ca18c1
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 20:51:14 2018 +0200
Merge branch 'thesis' of ssh://github.com/garniron/quantum_package into thesis
commit cfa8e1dc34
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 20:50:09 2018 +0200
restored relative_error
commit bccad69c77
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 20:47:11 2018 +0200
uninitialized variable
commit 52ca18c152
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 20:47:11 2018 +0200
uninitialized variable
commit ba0094f5f8
Merge: 093e3fd0 68458296
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 20:07:15 2018 +0200
merge with garniroy
commit 68458296dc
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Tue Sep 4 18:43:39 2018 +0200
Almost working but still broken
commit 9ebb88cbf3
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Tue Sep 4 18:05:00 2018 +0200
Cleaning
commit 873035e016
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Tue Sep 4 17:31:45 2018 +0200
Squashed commit of the following:
commit 4b9c435dce0f3b3078d573e66fd32b40fca26497
Merge: 74e559c8 093e3fd0
Author: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Tue Sep 4 16:58:51 2018 +0200
Merge branch 'thesis' of git://github.com/garniron/quantum_package into garniron-thesis
commit 093e3fd021
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 16:13:00 2018 +0200
removed ungodly hack
commit 8529a0f3f6
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:57:19 2018 +0200
reduced prints in pt2_stoch
commit 03b8f353bd
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:41:46 2018 +0200
teeth building check for pt2_stoch
commit 0d91b9310a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:35:04 2018 +0200
timestamp of first pull
commit 34d9fa0165
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:27:10 2018 +0200
potential numerical precision bug
commit 9a0f900d8c
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:09:51 2018 +0200
tests if teeth can be built
commit dda0dc34df
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 17:48:04 2018 +0200
corrected pt2_find_sample
commit a521f0cb82
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 16:08:02 2018 +0200
tasks get by batches of Nproc
commit 997a5a1265
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 14:18:04 2018 +0200
buffered task_id send
commit 99ea7948e0
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 12:29:12 2018 +0200
unbalanced fragmentation
commit abb3b7e08b
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sun Sep 2 17:18:44 2018 +0200
overflow of pt2_J
commit 8df49f394b
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sun Sep 2 15:58:48 2018 +0200
removed useless computation of intermediate checkpoints
commit 4ba5b79eb3
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sun Sep 2 15:50:14 2018 +0200
dressing only sent for chosen checkpoint
commit a4a6a69459
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sat Sep 1 17:01:56 2018 +0200
cumulative dot_F
commit 6a7f04cb79
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sat Sep 1 16:58:07 2018 +0200
simpler purge
commit 168ca2f2e2
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 21:07:01 2018 +0200
task list optimized
commit de4a0d0caf
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 18:57:03 2018 +0200
removed print
commit fee31d4e3e
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 18:56:23 2018 +0200
dress fragmentation
commit 02893a419d
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 15:52:16 2018 +0200
bug in blocked search - replaced with thesis version
commit bb6e073cf1
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 21:24:45 2018 +0200
ungodly hack to prevent double providing
commit 0609e8c627
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 20:52:05 2018 +0200
debugging
commit a254fdd7cf
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 15:24:07 2018 +0200
parallel bug
commit 2a6c1941d4
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 11:43:11 2018 +0200
corrected when relative_error=0d0
commit bac039bdf1
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 10:58:17 2018 +0200
relative error 1d-5
commit aae9d203ec
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 10:07:02 2018 +0200
potential fragmentation bug
commit ad69f39f99
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Wed Aug 29 20:54:58 2018 +0200
dress_zmq re-implemented
commit d78f64732a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Wed Aug 29 11:30:19 2018 +0200
pt2_stoch re-implemented
commit 4b9b54e19a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Aug 28 10:24:38 2018 +0200
removed test for phase_mask_bit
commit 3abccca5e3
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 3 23:44:05 2018 +0200
phasemask_bit
commit 093e3fd021
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 16:13:00 2018 +0200
removed ungodly hack
commit 8529a0f3f6
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:57:19 2018 +0200
reduced prints in pt2_stoch
commit 03b8f353bd
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:41:46 2018 +0200
teeth building check for pt2_stoch
commit 0d91b9310a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:35:04 2018 +0200
timestamp of first pull
commit 34d9fa0165
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:27:10 2018 +0200
potential numerical precision bug
commit 9a0f900d8c
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Sep 4 14:09:51 2018 +0200
tests if teeth can be built
commit dda0dc34df
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 17:48:04 2018 +0200
corrected pt2_find_sample
commit a521f0cb82
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 16:08:02 2018 +0200
tasks get by batches of Nproc
commit 997a5a1265
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 14:18:04 2018 +0200
buffered task_id send
commit 99ea7948e0
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Mon Sep 3 12:29:12 2018 +0200
unbalanced fragmentation
commit abb3b7e08b
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sun Sep 2 17:18:44 2018 +0200
overflow of pt2_J
commit 8df49f394b
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sun Sep 2 15:58:48 2018 +0200
removed useless computation of intermediate checkpoints
commit 4ba5b79eb3
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sun Sep 2 15:50:14 2018 +0200
dressing only sent for chosen checkpoint
commit a4a6a69459
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sat Sep 1 17:01:56 2018 +0200
cumulative dot_F
commit 6a7f04cb79
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Sat Sep 1 16:58:07 2018 +0200
simpler purge
commit 168ca2f2e2
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 21:07:01 2018 +0200
task list optimized
commit de4a0d0caf
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 18:57:03 2018 +0200
removed print
commit fee31d4e3e
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 18:56:23 2018 +0200
dress fragmentation
commit 02893a419d
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 31 15:52:16 2018 +0200
bug in blocked search - replaced with thesis version
commit bb6e073cf1
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 21:24:45 2018 +0200
ungodly hack to prevent double providing
commit 0609e8c627
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 20:52:05 2018 +0200
debugging
commit a254fdd7cf
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 15:24:07 2018 +0200
parallel bug
commit 2a6c1941d4
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 11:43:11 2018 +0200
corrected when relative_error=0d0
commit bac039bdf1
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 10:58:17 2018 +0200
relative error 1d-5
commit aae9d203ec
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Thu Aug 30 10:07:02 2018 +0200
potential fragmentation bug
commit ad69f39f99
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Wed Aug 29 20:54:58 2018 +0200
dress_zmq re-implemented
commit d78f64732a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Wed Aug 29 11:30:19 2018 +0200
pt2_stoch re-implemented
commit 4b9b54e19a
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Tue Aug 28 10:24:38 2018 +0200
removed test for phase_mask_bit
commit 3abccca5e3
Author: Yann Garniron <yann.garniron@yahoo.fr>
Date: Fri Aug 3 23:44:05 2018 +0200
phasemask_bit
This commit is contained in:
parent
74e559c85a
commit
4098b05202
|
|
@ -10,12 +10,11 @@ program fci_zmq
|
|||
|
||||
double precision :: hf_energy_ref
|
||||
logical :: has
|
||||
double precision :: relative_error, absolute_error
|
||||
double precision :: relative_error
|
||||
integer :: N_states_p
|
||||
character*(512) :: fmt
|
||||
|
||||
relative_error=PT2_relative_error
|
||||
absolute_error=PT2_absolute_error
|
||||
|
||||
pt2 = -huge(1.e0)
|
||||
threshold_davidson_in = threshold_davidson
|
||||
|
|
@ -72,7 +71,7 @@ program fci_zmq
|
|||
threshold_selectors = 1.d0
|
||||
threshold_generators = 1.d0
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
call ZMQ_pt2(CI_energy, pt2,relative_error,absolute_error,error) ! Stochastic PT2
|
||||
call ZMQ_pt2(CI_energy, pt2,relative_error,error) ! Stochastic PT2
|
||||
threshold_selectors = threshold_selectors_save
|
||||
threshold_generators = threshold_generators_save
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
|
|
@ -184,7 +183,7 @@ program fci_zmq
|
|||
threshold_selectors = 1.d0
|
||||
threshold_generators = 1d0
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
call ZMQ_pt2(CI_energy, pt2,relative_error,absolute_error,error) ! Stochastic PT2
|
||||
call ZMQ_pt2(CI_energy, pt2,relative_error,error) ! Stochastic PT2
|
||||
threshold_selectors = threshold_selectors_save
|
||||
threshold_generators = threshold_generators_save
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
|
|
|
|||
|
|
@ -1,246 +0,0 @@
|
|||
program fci_zmq
|
||||
implicit none
|
||||
integer :: i,j,k
|
||||
double precision, allocatable :: pt2(:)
|
||||
integer :: degree
|
||||
integer :: n_det_before, to_select
|
||||
double precision :: threshold_davidson_in
|
||||
|
||||
allocate (pt2(N_states))
|
||||
|
||||
double precision :: hf_energy_ref
|
||||
logical :: has
|
||||
double precision :: relative_error, absolute_error
|
||||
integer :: N_states_p
|
||||
character*(512) :: fmt
|
||||
|
||||
relative_error=PT2_relative_error
|
||||
absolute_error=PT2_absolute_error
|
||||
|
||||
pt2 = -huge(1.e0)
|
||||
threshold_davidson_in = threshold_davidson
|
||||
threshold_davidson = threshold_davidson_in * 100.d0
|
||||
SOFT_TOUCH threshold_davidson
|
||||
|
||||
call diagonalize_CI
|
||||
call save_wavefunction
|
||||
|
||||
call ezfio_has_hartree_fock_energy(has)
|
||||
if (has) then
|
||||
call ezfio_get_hartree_fock_energy(hf_energy_ref)
|
||||
else
|
||||
hf_energy_ref = ref_bitmask_energy
|
||||
endif
|
||||
|
||||
if (N_det > N_det_max) then
|
||||
psi_det = psi_det_sorted
|
||||
psi_coef = psi_coef_sorted
|
||||
N_det = N_det_max
|
||||
soft_touch N_det psi_det psi_coef
|
||||
call diagonalize_CI
|
||||
call save_wavefunction
|
||||
N_states_p = min(N_det,N_states)
|
||||
endif
|
||||
|
||||
n_det_before = 0
|
||||
|
||||
character*(8) :: pt2_string
|
||||
double precision :: correlation_energy_ratio
|
||||
double precision :: threshold_selectors_save, threshold_generators_save
|
||||
threshold_selectors_save = threshold_selectors
|
||||
threshold_generators_save = threshold_generators
|
||||
double precision :: error(N_states)
|
||||
|
||||
correlation_energy_ratio = 0.d0
|
||||
|
||||
if (.True.) then ! Avoid pre-calculation of CI_energy
|
||||
do while ( &
|
||||
(N_det < N_det_max) .and. &
|
||||
(maxval(abs(pt2(1:N_states))) > pt2_max) .and. &
|
||||
(correlation_energy_ratio <= correlation_energy_ratio_max) &
|
||||
)
|
||||
write(*,'(A)') '--------------------------------------------------------------------------------'
|
||||
|
||||
|
||||
if (do_pt2) then
|
||||
pt2_string = ' '
|
||||
pt2 = 0.d0
|
||||
threshold_selectors = 1.d0
|
||||
threshold_generators = 1d0
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
call ZMQ_pt2(CI_energy, pt2,relative_error,absolute_error,error) ! Stochastic PT2
|
||||
threshold_selectors = threshold_selectors_save
|
||||
threshold_generators = threshold_generators_save
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
else
|
||||
pt2_string = '(approx)'
|
||||
endif
|
||||
|
||||
|
||||
correlation_energy_ratio = (CI_energy(1) - hf_energy_ref) / &
|
||||
(CI_energy(1) + pt2(1) - hf_energy_ref)
|
||||
correlation_energy_ratio = min(1.d0,correlation_energy_ratio)
|
||||
|
||||
N_states_p = min(N_det,N_states)
|
||||
|
||||
print *, ''
|
||||
print '(A,I12)', 'Summary at N_det = ', N_det
|
||||
print '(A)', '-----------------------------------'
|
||||
print *, ''
|
||||
call write_double(6,correlation_energy_ratio, 'Correlation ratio')
|
||||
print *, ''
|
||||
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
write(fmt,*) '(12X,', N_states_p, '(6X,A7,1X,I6,10X))'
|
||||
write(*,fmt) ('State',k, k=1,N_states_p)
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
write(fmt,*) '(A12,', N_states_p, '(1X,F14.8,15X))'
|
||||
write(*,fmt) '# E ', CI_energy(1:N_states_p)
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', CI_energy(1:N_states_p)-CI_energy(1)
|
||||
write(*,fmt) '# Excit. (eV)', (CI_energy(1:N_states_p)-CI_energy(1))*27.211396641308d0
|
||||
endif
|
||||
write(fmt,*) '(A12,', 2*N_states_p, '(1X,F14.8))'
|
||||
write(*,fmt) '# PT2'//pt2_string, (pt2(k), error(k), k=1,N_states_p)
|
||||
write(*,'(A)') '#'
|
||||
write(*,fmt) '# E+PT2 ', (CI_energy(k)+pt2(k),error(k), k=1,N_states_p)
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1)), &
|
||||
dsqrt(error(k)*error(k)+error(1)*error(1)), k=1,N_states_p)
|
||||
write(*,fmt) '# Excit. (eV)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1))*27.211396641308d0, &
|
||||
dsqrt(error(k)*error(k)+error(1)*error(1))*27.211396641308d0, k=1,N_states_p)
|
||||
endif
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
print *, ''
|
||||
|
||||
print *, 'N_det = ', N_det
|
||||
print *, 'N_states = ', N_states
|
||||
print*, 'correlation_ratio = ', correlation_energy_ratio
|
||||
|
||||
do k=1, N_states_p
|
||||
print*,'State ',k
|
||||
print *, 'PT2 = ', pt2(k)
|
||||
print *, 'E = ', CI_energy(k)
|
||||
print *, 'E+PT2'//pt2_string//' = ', CI_energy(k)+pt2(k), ' +/- ', error(k)
|
||||
enddo
|
||||
|
||||
print *, '-----'
|
||||
if(N_states.gt.1)then
|
||||
print *, 'Variational Energy difference (au | eV)'
|
||||
do i=2, N_states_p
|
||||
print*,'Delta E = ', (CI_energy(i) - CI_energy(1)), &
|
||||
(CI_energy(i) - CI_energy(1)) * 27.211396641308d0
|
||||
enddo
|
||||
print *, '-----'
|
||||
print*, 'Variational + perturbative Energy difference (au | eV)'
|
||||
do i=2, N_states_p
|
||||
print*,'Delta E = ', (CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))), &
|
||||
(CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))) * 27.211396641308d0
|
||||
enddo
|
||||
endif
|
||||
call ezfio_set_full_ci_zmq_energy_pt2(CI_energy(1)+pt2(1))
|
||||
call dump_fci_iterations_value(N_det,CI_energy,pt2)
|
||||
|
||||
n_det_before = N_det
|
||||
if (s2_eig) then
|
||||
to_select = N_det/2+1
|
||||
to_select = max(N_det/2+1, to_select)
|
||||
to_select = min(to_select, N_det_max-n_det_before)
|
||||
else
|
||||
to_select = N_det
|
||||
to_select = max(N_det, to_select)
|
||||
to_select = min(to_select, N_det_max-n_det_before)
|
||||
endif
|
||||
call save_natural_mos
|
||||
call map_deinit(mo_integrals_map)
|
||||
FREE mo_integrals_map
|
||||
PROVIDE mo_integrals_map
|
||||
call four_index_transform_block(ao_integrals_map,mo_integrals_map, &
|
||||
mo_coef, size(mo_coef,1), &
|
||||
1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, &
|
||||
1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num)
|
||||
|
||||
call ZMQ_selection(to_select, pt2)
|
||||
|
||||
PROVIDE psi_coef
|
||||
PROVIDE psi_det
|
||||
PROVIDE psi_det_sorted
|
||||
|
||||
if (N_det >= N_det_max) then
|
||||
threshold_davidson = threshold_davidson_in
|
||||
end if
|
||||
call diagonalize_CI
|
||||
call save_wavefunction
|
||||
call ezfio_set_full_ci_zmq_energy(CI_energy(1))
|
||||
enddo
|
||||
endif
|
||||
|
||||
if (N_det < N_det_max) then
|
||||
threshold_davidson = threshold_davidson_in
|
||||
call diagonalize_CI
|
||||
call save_wavefunction
|
||||
call ezfio_set_full_ci_zmq_energy(CI_energy(1))
|
||||
call ezfio_set_full_ci_zmq_energy_pt2(CI_energy(1)+pt2(1))
|
||||
endif
|
||||
|
||||
if (do_pt2) then
|
||||
pt2 = 0.d0
|
||||
threshold_selectors = 1.d0
|
||||
threshold_generators = 1d0
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
call ZMQ_pt2(CI_energy, pt2,relative_error,absolute_error,error) ! Stochastic PT2
|
||||
threshold_selectors = threshold_selectors_save
|
||||
threshold_generators = threshold_generators_save
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
call ezfio_set_full_ci_zmq_energy(CI_energy(1))
|
||||
call ezfio_set_full_ci_zmq_energy_pt2(CI_energy(1)+pt2(1))
|
||||
endif
|
||||
print *, 'N_det = ', N_det
|
||||
print *, 'N_states = ', N_states
|
||||
print*, 'correlation_ratio = ', correlation_energy_ratio
|
||||
|
||||
|
||||
call dump_fci_iterations_value(N_det,CI_energy,pt2)
|
||||
|
||||
print *, ''
|
||||
print '(A,I12)', 'Summary at N_det = ', N_det
|
||||
print '(A)', '-----------------------------------'
|
||||
print *, ''
|
||||
call write_double(6,correlation_energy_ratio, 'Correlation ratio')
|
||||
print *, ''
|
||||
|
||||
|
||||
N_states_p = min(N_det,N_states)
|
||||
print *, ''
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
write(fmt,*) '(12X,', N_states_p, '(6X,A7,1X,I6,10X))'
|
||||
write(*,fmt) ('State',k, k=1,N_states_p)
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
write(fmt,*) '(A12,', N_states_p, '(1X,F14.8,15X))'
|
||||
write(*,fmt) '# E ', CI_energy(1:N_states_p)
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', CI_energy(1:N_states_p)-CI_energy(1)
|
||||
write(*,fmt) '# Excit. (eV)', (CI_energy(1:N_states_p)-CI_energy(1))*27.211396641308d0
|
||||
endif
|
||||
write(fmt,*) '(A12,', 2*N_states_p, '(1X,F14.8))'
|
||||
write(*,fmt) '# PT2'//pt2_string, (pt2(k), error(k), k=1,N_states_p)
|
||||
write(*,'(A)') '#'
|
||||
write(*,fmt) '# E+PT2 ', (CI_energy(k)+pt2(k),error(k), k=1,N_states_p)
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1)), &
|
||||
dsqrt(error(k)*error(k)+error(1)*error(1)), k=1,N_states_p)
|
||||
write(*,fmt) '# Excit. (eV)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1))*27.211396641308d0, &
|
||||
dsqrt(error(k)*error(k)+error(1)*error(1))*27.211396641308d0, k=1,N_states_p)
|
||||
endif
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
print *, ''
|
||||
|
||||
|
||||
|
||||
end
|
||||
|
|
@ -12,30 +12,30 @@ subroutine run
|
|||
integer :: i,j,k
|
||||
logical, external :: detEq
|
||||
|
||||
double precision, allocatable :: pt2(:)
|
||||
double precision :: pt2(N_states)
|
||||
integer :: degree
|
||||
integer :: n_det_before, to_select
|
||||
double precision :: threshold_davidson_in
|
||||
|
||||
double precision :: E_CI_before, relative_error, absolute_error, eqt
|
||||
|
||||
allocate (pt2(N_states))
|
||||
|
||||
double precision :: E_CI_before(N_states), relative_error, error(N_states)
|
||||
|
||||
pt2(:) = 0.d0
|
||||
|
||||
E_CI_before = psi_energy(1) + nuclear_repulsion
|
||||
E_CI_before(:) = psi_energy(:) + nuclear_repulsion
|
||||
threshold_selectors = 1.d0
|
||||
threshold_generators = 1.d0
|
||||
threshold_generators = 1.d0
|
||||
relative_error=PT2_relative_error
|
||||
absolute_error=PT2_absolute_error
|
||||
|
||||
call ZMQ_pt2(E_CI_before, pt2, relative_error, absolute_error, eqt)
|
||||
print *, 'Final step'
|
||||
print *, 'N_det = ', N_det
|
||||
print *, 'PT2 = ', pt2
|
||||
print *, 'E = ', E_CI_before
|
||||
print *, 'E+PT2 = ', E_CI_before+pt2, ' +/- ', eqt
|
||||
print *, '-----'
|
||||
call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2(1))
|
||||
|
||||
call ZMQ_pt2(E_CI_before, pt2, relative_error, error)
|
||||
do k=1,N_states
|
||||
print *, 'State ', k
|
||||
print *, 'N_det = ', N_det
|
||||
print *, 'PT2 = ', pt2
|
||||
print *, 'E = ', E_CI_before(k)
|
||||
print *, 'E+PT2 = ', E_CI_before(k)+pt2(k), ' +/- ', error(k)
|
||||
print *, '-----'
|
||||
enddo
|
||||
call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1))
|
||||
end
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,32 +1,108 @@
|
|||
BEGIN_PROVIDER [ integer, fragment_first ]
|
||||
implicit none
|
||||
fragment_first = first_det_of_teeth(1)
|
||||
BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! State for stochatsic PT2
|
||||
END_DOC
|
||||
pt2_stoch_istate = 1
|
||||
END_PROVIDER
|
||||
|
||||
subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error)
|
||||
|
||||
BEGIN_PROVIDER [ integer, pt2_N_teeth ]
|
||||
&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ]
|
||||
&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
|
||||
&BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ]
|
||||
implicit none
|
||||
logical, external :: testTeethBuilding
|
||||
integer :: i
|
||||
pt2_F(:) = 1
|
||||
pt2_n_tasks_max = N_det_generators/100 + 1
|
||||
do i=1,N_det_generators
|
||||
if (maxval(dabs(psi_coef_sorted_gen(i,:))) > 0.005d0) then
|
||||
pt2_F(i) = max(1,min( ((elec_alpha_num-n_core_orb)**2)/4, pt2_n_tasks_max))
|
||||
endif
|
||||
enddo
|
||||
|
||||
if(N_det_generators < 1024) then
|
||||
pt2_minDetInFirstTeeth = 1
|
||||
pt2_N_teeth = 1
|
||||
else
|
||||
pt2_minDetInFirstTeeth = min(5, N_det_generators)
|
||||
do pt2_N_teeth=100,2,-1
|
||||
if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit
|
||||
end do
|
||||
end if
|
||||
call write_int(6,pt2_N_teeth,'Number of comb teeth')
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
logical function testTeethBuilding(minF, N)
|
||||
implicit none
|
||||
integer, intent(in) :: minF, N
|
||||
integer :: n0, i
|
||||
double precision :: u0, Wt, r
|
||||
|
||||
double precision, allocatable :: tilde_w(:), tilde_cW(:)
|
||||
integer, external :: dress_find_sample
|
||||
|
||||
allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
|
||||
|
||||
do i=1,N_det_generators
|
||||
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 + 1.d-20
|
||||
enddo
|
||||
|
||||
double precision :: norm
|
||||
norm = 0.d0
|
||||
do i=N_det_generators,1,-1
|
||||
norm += tilde_w(i)
|
||||
enddo
|
||||
|
||||
tilde_w(:) = tilde_w(:) / norm
|
||||
|
||||
tilde_cW(0) = -1.d0
|
||||
do i=1,N_det_generators
|
||||
tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
|
||||
enddo
|
||||
tilde_cW(:) = tilde_cW(:) + 1.d0
|
||||
|
||||
n0 = 0
|
||||
testTeethBuilding = .false.
|
||||
do
|
||||
u0 = tilde_cW(n0)
|
||||
r = tilde_cW(n0 + minF)
|
||||
Wt = (1d0 - u0) / dble(N)
|
||||
if (dabs(Wt) <= 1.d-3) then
|
||||
return
|
||||
endif
|
||||
if(Wt >= r - u0) then
|
||||
testTeethBuilding = .true.
|
||||
return
|
||||
end if
|
||||
n0 += 1
|
||||
if(N_det_generators - n0 < minF * N) then
|
||||
return
|
||||
end if
|
||||
end do
|
||||
stop "exited testTeethBuilding"
|
||||
end function
|
||||
|
||||
|
||||
|
||||
subroutine ZMQ_pt2(E, pt2,relative_error, error)
|
||||
use f77_zmq
|
||||
use selection_types
|
||||
|
||||
implicit none
|
||||
|
||||
character(len=64000) :: task
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
|
||||
type(selection_buffer) :: b
|
||||
integer, external :: omp_get_thread_num
|
||||
double precision, intent(in) :: relative_error, absolute_error, E(N_states)
|
||||
double precision, intent(in) :: relative_error, E(N_states)
|
||||
double precision, intent(out) :: pt2(N_states),error(N_states)
|
||||
|
||||
|
||||
double precision, allocatable :: pt2_detail(:,:), comb(:)
|
||||
logical, allocatable :: computed(:)
|
||||
integer, allocatable :: tbc(:)
|
||||
integer :: i, j, k, Ncomb, i_generator_end
|
||||
integer, external :: pt2_find
|
||||
integer :: i
|
||||
|
||||
double precision :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth)
|
||||
double precision, external :: omp_get_wtime
|
||||
double precision :: state_average_weight_save(N_states), w(N_states)
|
||||
double precision :: time
|
||||
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
|
||||
|
||||
if (N_det < max(10,N_states)) then
|
||||
|
|
@ -40,26 +116,9 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error)
|
|||
state_average_weight(:) = 0.d0
|
||||
state_average_weight(pt2_stoch_istate) = 1.d0
|
||||
TOUCH state_average_weight pt2_stoch_istate
|
||||
|
||||
allocate(pt2_detail(N_states,N_det_generators+1), comb(N_det_generators), computed(N_det_generators), tbc(0:size_tbc))
|
||||
sumabove = 0d0
|
||||
sum2above = 0d0
|
||||
Nabove = 0d0
|
||||
|
||||
provide nproc fragment_first fragment_count mo_bielec_integrals_in_map mo_mono_elec_integral pt2_weight psi_selectors
|
||||
|
||||
computed = .false.
|
||||
|
||||
tbc(0) = first_det_of_comb - 1
|
||||
do i=1, tbc(0)
|
||||
tbc(i) = i
|
||||
computed(i) = .true.
|
||||
end do
|
||||
|
||||
Ncomb=size(comb)
|
||||
call get_carlo_workbatch(computed, comb, Ncomb, tbc)
|
||||
|
||||
pt2_detail = 0d0
|
||||
provide nproc pt2_F mo_bielec_integrals_in_map mo_mono_elec_integral pt2_w psi_selectors
|
||||
|
||||
print *, '========== ================= ================= ================='
|
||||
print *, ' Samples Energy Stat. Error Seconds '
|
||||
print *, '========== ================= ================= ================='
|
||||
|
|
@ -97,16 +156,15 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error)
|
|||
endif
|
||||
|
||||
|
||||
call create_selection_buffer(1, 1*2, b)
|
||||
|
||||
integer :: ipos
|
||||
ipos=1
|
||||
|
||||
integer, external :: add_task_to_taskserver
|
||||
|
||||
do i=1,tbc(0)
|
||||
if(tbc(i) > fragment_first) then
|
||||
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') 0, tbc(i)
|
||||
character(len=64000) :: task
|
||||
integer :: j,k,ipos
|
||||
ipos=1
|
||||
task = ' '
|
||||
|
||||
do i= 1, N_det_generators
|
||||
do j=1,pt2_F(pt2_J(i))
|
||||
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, pt2_J(i)
|
||||
ipos += 20
|
||||
if (ipos > 63980) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
|
|
@ -114,19 +172,8 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error)
|
|||
endif
|
||||
ipos=1
|
||||
endif
|
||||
else
|
||||
do j=1,fragment_count
|
||||
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i)
|
||||
ipos += 20
|
||||
if (ipos > 63980) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
stop 'Unable to add task to task server'
|
||||
endif
|
||||
ipos=1
|
||||
endif
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
enddo
|
||||
if (ipos > 1) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
stop 'Unable to add task to task server'
|
||||
|
|
@ -149,24 +196,26 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error)
|
|||
nproc_target = min(nproc_target,nproc)
|
||||
endif
|
||||
|
||||
call omp_set_nested(.true.)
|
||||
|
||||
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
|
||||
!$OMP PRIVATE(i)
|
||||
i = omp_get_thread_num()
|
||||
if (i==0) then
|
||||
call pt2_collector(zmq_socket_pull,E(pt2_stoch_istate), b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, absolute_error, w, error)
|
||||
call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, w, error)
|
||||
pt2(pt2_stoch_istate) = w(pt2_stoch_istate)
|
||||
else
|
||||
call pt2_slave_inproc(i)
|
||||
endif
|
||||
!$OMP END PARALLEL
|
||||
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
|
||||
call delete_selection_buffer(b)
|
||||
|
||||
print *, '========== ================= ================= ================='
|
||||
|
||||
deallocate(pt2_detail, comb, computed, tbc)
|
||||
enddo
|
||||
FREE pt2_stoch_istate
|
||||
! call omp_set_nested(.false.)
|
||||
|
||||
FREE pt2_stoch_istate
|
||||
state_average_weight(:) = state_average_weight_save(:)
|
||||
TOUCH state_average_weight
|
||||
endif
|
||||
|
|
@ -177,34 +226,6 @@ subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, error)
|
|||
end subroutine
|
||||
|
||||
|
||||
subroutine do_carlo(tbc, Ncomb, comb, pt2_detail, computed, sumabove, sum2above, Nabove)
|
||||
integer, intent(in) :: tbc(0:size_tbc), Ncomb
|
||||
logical, intent(in) :: computed(N_det_generators)
|
||||
double precision, intent(in) :: comb(Ncomb), pt2_detail(N_states,N_det_generators)
|
||||
double precision, intent(inout) :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth)
|
||||
integer :: i, dets(comb_teeth)
|
||||
double precision :: myVal, myVal2
|
||||
|
||||
mainLoop : do i=1,Ncomb
|
||||
call get_comb(comb(i), dets, comb_teeth)
|
||||
do j=1,comb_teeth
|
||||
if(.not.(computed(dets(j)))) then
|
||||
exit mainLoop
|
||||
end if
|
||||
end do
|
||||
|
||||
myVal = 0d0
|
||||
myVal2 = 0d0
|
||||
do j=comb_teeth,1,-1
|
||||
myVal += pt2_detail(pt2_stoch_istate,dets(j)) * pt2_weight_inv(dets(j)) * comb_step
|
||||
sumabove(j) += myVal
|
||||
sum2above(j) += myVal*myVal
|
||||
Nabove(j) += 1
|
||||
end do
|
||||
end do mainLoop
|
||||
end subroutine
|
||||
|
||||
|
||||
subroutine pt2_slave_inproc(i)
|
||||
implicit none
|
||||
integer, intent(in) :: i
|
||||
|
|
@ -212,411 +233,289 @@ subroutine pt2_slave_inproc(i)
|
|||
call run_pt2_slave(1,i,pt2_e0_denominator)
|
||||
end
|
||||
|
||||
subroutine pt2_collector(zmq_socket_pull, E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, absolute_error, pt2,error)
|
||||
|
||||
subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error)
|
||||
use f77_zmq
|
||||
use selection_types
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
|
||||
integer, intent(in) :: Ncomb
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
|
||||
double precision, intent(inout) :: pt2_detail(N_states, N_det_generators)
|
||||
double precision, intent(in) :: comb(Ncomb), relative_error, absolute_error, E
|
||||
logical, intent(inout) :: computed(N_det_generators)
|
||||
integer, intent(in) :: tbc(0:size_tbc)
|
||||
double precision, intent(inout) :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth)
|
||||
double precision, intent(out) :: pt2(N_states),error(N_states)
|
||||
double precision, intent(in) :: relative_error, E
|
||||
double precision, intent(out) :: pt2(N_states), error(N_states)
|
||||
|
||||
|
||||
type(selection_buffer), intent(inout) :: b
|
||||
double precision, allocatable :: pt2_mwen(:,:)
|
||||
double precision, allocatable :: eI(:,:), eI_task(:,:), S(:), S2(:)
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
integer, external :: zmq_delete_tasks
|
||||
integer, external :: zmq_abort
|
||||
integer, external :: pt2_find_sample
|
||||
|
||||
|
||||
integer :: msg_size, rc, more
|
||||
integer :: acc, i, j, robin, N, n_tasks
|
||||
double precision, allocatable :: val(:)
|
||||
integer(bit_kind), allocatable :: det(:,:,:)
|
||||
integer :: more, n, i, p, c, t, n_tasks, U
|
||||
integer, allocatable :: task_id(:)
|
||||
integer, allocatable :: index(:)
|
||||
double precision :: time0
|
||||
double precision :: time, timeLast, Nabove_old
|
||||
|
||||
double precision, external :: omp_get_wtime
|
||||
integer :: tooth, firstTBDcomb, orgTBDcomb, n_tasks_max
|
||||
integer, allocatable :: parts_to_get(:)
|
||||
logical, allocatable :: actually_computed(:)
|
||||
double precision :: eqt
|
||||
character*(512) :: task
|
||||
Nabove_old = -1.d0
|
||||
n_tasks_max = N_det_generators/100+1
|
||||
double precision :: v, x, avg, eqt, E0
|
||||
double precision :: time, time0
|
||||
|
||||
allocate(actually_computed(N_det_generators), parts_to_get(N_det_generators), &
|
||||
pt2_mwen(N_states, n_tasks_max) )
|
||||
|
||||
pt2_mwen(1:N_states, 1:n_tasks_max) = 0.d0
|
||||
do i=1,N_det_generators
|
||||
actually_computed(i) = computed(i)
|
||||
enddo
|
||||
|
||||
parts_to_get(:) = 1
|
||||
if(fragment_first > 0) then
|
||||
do i=1,fragment_first
|
||||
parts_to_get(i) = fragment_count
|
||||
enddo
|
||||
endif
|
||||
|
||||
do i=1,tbc(0)
|
||||
actually_computed(tbc(i)) = .false.
|
||||
end do
|
||||
|
||||
orgTBDcomb = int(Nabove(1))
|
||||
firstTBDcomb = 1
|
||||
integer, allocatable :: f(:)
|
||||
logical, allocatable :: d(:)
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
allocate(val(b%N), det(N_int, 2, b%N), task_id(n_tasks_max), index(n_tasks_max))
|
||||
allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators))
|
||||
allocate(d(N_det_generators+1))
|
||||
allocate(eI(N_states, N_det_generators), eI_task(N_states, pt2_n_tasks_max))
|
||||
allocate(S(pt2_N_teeth+1), S2(pt2_N_teeth+1))
|
||||
|
||||
pt2(:) = -huge(1.)
|
||||
S(:) = 0d0
|
||||
S2(:) = 0d0
|
||||
n = 1
|
||||
t = 0
|
||||
U = 0
|
||||
eI(:,:) = 0d0
|
||||
f(:) = pt2_F(:)
|
||||
d(:) = .false.
|
||||
n_tasks = 0
|
||||
E0 = E
|
||||
more = 1
|
||||
call wall_time(time0)
|
||||
timeLast = time0
|
||||
time0 = omp_get_wtime()
|
||||
|
||||
call get_first_tooth(actually_computed, tooth)
|
||||
Nabove_old = Nabove(tooth)
|
||||
|
||||
logical :: loop
|
||||
loop = .True.
|
||||
pullLoop : do while (loop)
|
||||
do while (n <= N_det_generators)
|
||||
if(f(pt2_J(n)) == 0) then
|
||||
d(pt2_J(n)) = .true.
|
||||
do while(d(U+1))
|
||||
U += 1
|
||||
end do
|
||||
|
||||
call pull_pt2_results(zmq_socket_pull, index, pt2_mwen, task_id, n_tasks)
|
||||
do i=1,n_tasks
|
||||
pt2_detail(1:N_states, index(i)) += pt2_mwen(1:N_states,i)
|
||||
parts_to_get(index(i)) -= 1
|
||||
if(parts_to_get(index(i)) < 0) then
|
||||
print *, i, index(i), parts_to_get(index(i))
|
||||
print *, parts_to_get
|
||||
stop "PARTS ??"
|
||||
end if
|
||||
if(parts_to_get(index(i)) == 0) actually_computed(index(i)) = .true.
|
||||
enddo
|
||||
|
||||
integer, external :: zmq_delete_tasks
|
||||
if (zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n_tasks,more) == -1) then
|
||||
cycle
|
||||
endif
|
||||
if (more == 0) then
|
||||
loop = .False.
|
||||
endif
|
||||
|
||||
call wall_time(time)
|
||||
|
||||
|
||||
if(time - timeLast > 5d0 .or. (.not.loop)) then
|
||||
timeLast = time
|
||||
do i=1, first_det_of_teeth(1)-1
|
||||
if(.not.(actually_computed(i))) then
|
||||
cycle pullLoop
|
||||
! Deterministic part
|
||||
do while(t <= pt2_N_teeth)
|
||||
if(U >= pt2_n_0(t+1)) then
|
||||
t=t+1
|
||||
E0 = 0.d0
|
||||
do i=pt2_n_0(t),1,-1
|
||||
E0 += eI(pt2_stoch_istate, i)
|
||||
end do
|
||||
else
|
||||
exit
|
||||
end if
|
||||
end do
|
||||
|
||||
integer, external :: zmq_abort
|
||||
double precision :: E0, avg, prop
|
||||
|
||||
call do_carlo(tbc, Ncomb+1-firstTBDcomb, comb(firstTBDcomb), pt2_detail, actually_computed, sumabove, sum2above, Nabove)
|
||||
firstTBDcomb = int(Nabove(1)) - orgTBDcomb + 1
|
||||
call get_first_tooth(actually_computed, tooth)
|
||||
|
||||
if (firstTBDcomb > Ncomb) then
|
||||
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
|
||||
call sleep(1)
|
||||
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Error in sending abort signal (1)'
|
||||
endif
|
||||
endif
|
||||
! exit pullLoop
|
||||
endif
|
||||
|
||||
E0 = sum(pt2_detail(pt2_stoch_istate,:first_det_of_teeth(tooth)-1))
|
||||
if (tooth <= comb_teeth) then
|
||||
prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1))
|
||||
prop = prop * pt2_weight_inv(first_det_of_teeth(tooth))
|
||||
E0 += pt2_detail(pt2_stoch_istate,first_det_of_teeth(tooth)) * prop
|
||||
avg = E0 + (sumabove(tooth) / Nabove(tooth))
|
||||
eqt = sqrt(1d0 / (Nabove(tooth)-1.d0) * abs(sum2above(tooth) / Nabove(tooth) - (sumabove(tooth)/Nabove(tooth))**2))
|
||||
else
|
||||
eqt = 0.d0
|
||||
tooth=comb_teeth
|
||||
endif
|
||||
call wall_time(time)
|
||||
if ( ((dabs(eqt/avg) < relative_error) .or. (dabs(eqt) < absolute_error)) .and. Nabove(tooth) >= 10.d0) then
|
||||
! Termination
|
||||
|
||||
! Add Stochastic part
|
||||
c = pt2_R(n)
|
||||
if(c > 0) then
|
||||
x = 0d0
|
||||
do p=pt2_N_teeth, 1, -1
|
||||
v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1))
|
||||
i = pt2_find_sample(v, pt2_cW)
|
||||
x += eI(pt2_stoch_istate, i) * pt2_W_T / pt2_w(i)
|
||||
S(p) += x
|
||||
S2(p) += x**2
|
||||
end do
|
||||
avg = E0 + S(t) / dble(c)
|
||||
pt2(pt2_stoch_istate) = avg
|
||||
error(pt2_stoch_istate) = eqt
|
||||
print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, ''
|
||||
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
|
||||
call sleep(1)
|
||||
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Error in sending abort signal (2)'
|
||||
! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969)
|
||||
if(c > 2) then
|
||||
eqt = dabs((S2(t) / c) - (S(t)/c)**2) ! dabs for numerical stability
|
||||
eqt = sqrt(eqt / (dble(c) - 1.5d0))
|
||||
error(pt2_stoch_istate) = eqt
|
||||
if(mod(c,10)==0 .or. n==N_det_generators) then
|
||||
print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', c, avg+E, eqt, time-time0, ''
|
||||
if( dabs(error(pt2_stoch_istate) / pt2(pt2_stoch_istate)) < relative_error) then
|
||||
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
|
||||
call sleep(1)
|
||||
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Error in sending abort signal (2)'
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
else
|
||||
if ( (Nabove(tooth) > 2.d0) .and. (Nabove(tooth) > Nabove_old) ) then
|
||||
print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, ''
|
||||
Nabove_old = Nabove(tooth)
|
||||
endif
|
||||
time = omp_get_wtime()
|
||||
end if
|
||||
n += 1
|
||||
else if(more == 0) then
|
||||
exit
|
||||
else
|
||||
call pull_pt2_results(zmq_socket_pull, index, eI_task, task_id, n_tasks)
|
||||
if (zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n_tasks,more) == -1) then
|
||||
stop 'Unable to delete tasks'
|
||||
endif
|
||||
do i=1,n_tasks
|
||||
eI(:, index(i)) += eI_task(:, i)
|
||||
f(index(i)) -= 1
|
||||
end do
|
||||
end if
|
||||
end do pullLoop
|
||||
|
||||
if(tooth == comb_teeth+1) then
|
||||
pt2(pt2_stoch_istate) = sum(pt2_detail(pt2_stoch_istate,:))
|
||||
error(pt2_stoch_istate) = 0d0
|
||||
else
|
||||
E0 = sum(pt2_detail(pt2_stoch_istate,:first_det_of_teeth(tooth)-1))
|
||||
prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1))
|
||||
prop = prop * pt2_weight_inv(first_det_of_teeth(tooth))
|
||||
E0 += pt2_detail(pt2_stoch_istate,first_det_of_teeth(tooth)) * prop
|
||||
pt2(pt2_stoch_istate) = E0 + (sumabove(tooth) / Nabove(tooth))
|
||||
error(pt2_stoch_istate) = sqrt(1d0 / (Nabove(tooth)-1) * abs(sum2above(tooth) / Nabove(tooth) - (sumabove(tooth)/Nabove(tooth))**2))
|
||||
end if
|
||||
|
||||
end do
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
call sort_selection_buffer(b)
|
||||
end subroutine
|
||||
|
||||
integer function pt2_find(v, w, sze, imin, imax)
|
||||
|
||||
integer function pt2_find_sample(v, w)
|
||||
implicit none
|
||||
integer, intent(in) :: sze, imin, imax
|
||||
double precision, intent(in) :: v, w(sze)
|
||||
integer :: i,l,h
|
||||
integer, parameter :: block=64
|
||||
double precision, intent(in) :: v, w(0:N_det_generators)
|
||||
integer :: i,l,r
|
||||
|
||||
l = imin
|
||||
h = imax-1
|
||||
l = 0
|
||||
r = N_det_generators
|
||||
|
||||
do while(h-l >= block)
|
||||
i = ishft(h+l,-1)
|
||||
if(w(i+1) > v) then
|
||||
h = i-1
|
||||
do while(r-l > 1)
|
||||
i = (r+l) / 2
|
||||
if(w(i) < v) then
|
||||
l = i
|
||||
else
|
||||
l = i+1
|
||||
r = i
|
||||
end if
|
||||
end do
|
||||
!DIR$ LOOP COUNT (64)
|
||||
do pt2_find=l,h
|
||||
if(w(pt2_find) >= v) then
|
||||
i = r
|
||||
do r=i+1,N_det_generators
|
||||
if (w(r) /= w(i)) then
|
||||
exit
|
||||
end if
|
||||
end do
|
||||
endif
|
||||
enddo
|
||||
pt2_find_sample = r-1
|
||||
end function
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, comb_teeth ]
|
||||
BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)]
|
||||
&BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)]
|
||||
&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of teeth in the comb
|
||||
END_DOC
|
||||
comb_teeth = min(1+N_det/10,100)
|
||||
integer :: N_c, N_j, U, t, i
|
||||
double precision :: v
|
||||
logical, allocatable :: d(:)
|
||||
integer, external :: pt2_find_sample
|
||||
|
||||
allocate(d(N_det_generators))
|
||||
|
||||
pt2_R(:) = 0
|
||||
N_c = 0
|
||||
N_j = pt2_n_0(1)
|
||||
d(:) = .false.
|
||||
|
||||
do i=1,N_j
|
||||
d(i) = .true.
|
||||
pt2_J(i) = i
|
||||
end do
|
||||
call random_seed(put=(/3211,64,6566,321,65,321,654,65,321,6321,654,65,321,621,654,65,321,65,654,65,321,65/))
|
||||
call RANDOM_NUMBER(pt2_u)
|
||||
call RANDOM_NUMBER(pt2_u)
|
||||
|
||||
|
||||
|
||||
U = 0
|
||||
|
||||
do while(N_j < N_det_generators)
|
||||
!ADD_COMB
|
||||
N_c += 1
|
||||
do t=0, pt2_N_teeth-1
|
||||
v = pt2_u_0 + pt2_W_T * (dble(t) + pt2_u(N_c))
|
||||
i = pt2_find_sample(v, pt2_cW)
|
||||
if(.not. d(i)) then
|
||||
N_j += 1
|
||||
pt2_J(N_j) = i
|
||||
d(i) = .true.
|
||||
end if
|
||||
end do
|
||||
|
||||
pt2_R(N_j) = N_c
|
||||
|
||||
!FILL_TOOTH
|
||||
do while(U < N_det_generators)
|
||||
U += 1
|
||||
if(.not. d(U)) then
|
||||
N_j += 1
|
||||
pt2_J(N_j) = U
|
||||
d(U) = .true.
|
||||
exit;
|
||||
end if
|
||||
end do
|
||||
enddo
|
||||
if(N_det_generators > 1) then
|
||||
pt2_R(N_det_generators-1) = 0
|
||||
pt2_R(N_det_generators) = N_c
|
||||
end if
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
subroutine get_first_tooth(computed, first_teeth)
|
||||
BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ]
|
||||
&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ]
|
||||
&BEGIN_PROVIDER [ double precision, pt2_W_T ]
|
||||
&BEGIN_PROVIDER [ double precision, pt2_u_0 ]
|
||||
&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ]
|
||||
implicit none
|
||||
logical, intent(in) :: computed(N_det_generators)
|
||||
integer, intent(out) :: first_teeth
|
||||
integer :: i, first_det
|
||||
integer :: i, t
|
||||
double precision, allocatable :: tilde_w(:), tilde_cW(:)
|
||||
double precision :: r, tooth_width
|
||||
integer, external :: pt2_find_sample
|
||||
|
||||
first_det = N_det_generators+1+1
|
||||
first_teeth = 1
|
||||
do i=first_det_of_comb, N_det_generators
|
||||
if(.not.(computed(i))) then
|
||||
first_det = i
|
||||
allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
|
||||
|
||||
tilde_cW(0) = 0d0
|
||||
|
||||
do i=1,N_det_generators
|
||||
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 + 1.d-20
|
||||
enddo
|
||||
|
||||
double precision :: norm
|
||||
norm = 0.d0
|
||||
do i=N_det_generators,1,-1
|
||||
norm += tilde_w(i)
|
||||
enddo
|
||||
|
||||
tilde_w(:) = tilde_w(:) / norm
|
||||
|
||||
tilde_cW(0) = -1.d0
|
||||
do i=1,N_det_generators
|
||||
tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
|
||||
enddo
|
||||
tilde_cW(:) = tilde_cW(:) + 1.d0
|
||||
|
||||
pt2_n_0(1) = 0
|
||||
do
|
||||
pt2_u_0 = tilde_cW(pt2_n_0(1))
|
||||
r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
|
||||
pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
|
||||
if(pt2_W_T >= r - pt2_u_0) then
|
||||
exit
|
||||
end if
|
||||
end do
|
||||
|
||||
do i=comb_teeth+1, 1, -1
|
||||
if(first_det_of_teeth(i) < first_det) then
|
||||
first_teeth = i
|
||||
exit
|
||||
pt2_n_0(1) += 1
|
||||
if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
|
||||
stop "teeth building failed"
|
||||
end if
|
||||
end do
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer*8, size_tbc ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Size of the tbc array
|
||||
END_DOC
|
||||
size_tbc = int((comb_teeth+1),8)*int(N_det_generators,8) + fragment_count*fragment_first
|
||||
END_PROVIDER
|
||||
|
||||
subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc)
|
||||
implicit none
|
||||
integer, intent(inout) :: Ncomb
|
||||
double precision, intent(out) :: comb(Ncomb)
|
||||
integer, intent(inout) :: tbc(0:size_tbc)
|
||||
logical, intent(inout) :: computed(N_det_generators)
|
||||
integer :: i, j, last_full, dets(comb_teeth)
|
||||
integer :: icount, n
|
||||
integer :: k, l
|
||||
l=first_det_of_comb
|
||||
call RANDOM_NUMBER(comb)
|
||||
do i=1,size(comb)
|
||||
comb(i) = comb(i) * comb_step
|
||||
!DIR$ FORCEINLINE
|
||||
call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth)
|
||||
Ncomb = i
|
||||
if (tbc(0) == N_det_generators) return
|
||||
do while (computed(l))
|
||||
l=l+1
|
||||
enddo
|
||||
k=tbc(0)+1
|
||||
tbc(k) = l
|
||||
computed(l) = .True.
|
||||
tbc(0) = k
|
||||
enddo
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
|
||||
subroutine get_comb(stato, dets, ct)
|
||||
implicit none
|
||||
integer, intent(in) :: ct
|
||||
double precision, intent(in) :: stato
|
||||
integer, intent(out) :: dets(ct)
|
||||
double precision :: curs
|
||||
integer :: j
|
||||
integer, external :: pt2_find
|
||||
|
||||
curs = 1d0 - stato
|
||||
do j = comb_teeth, 1, -1
|
||||
!DIR$ FORCEINLINE
|
||||
dets(j) = pt2_find(curs, pt2_cweight,size(pt2_cweight), first_det_of_teeth(j), first_det_of_teeth(j+1))
|
||||
curs -= comb_step
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
do t=2, pt2_N_teeth
|
||||
r = pt2_u_0 + pt2_W_T * dble(t-1)
|
||||
pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
|
||||
end do
|
||||
end subroutine
|
||||
|
||||
|
||||
subroutine add_comb(comb, computed, tbc, stbc, ct)
|
||||
implicit none
|
||||
integer*8, intent(in) :: stbc
|
||||
integer, intent(in) :: ct
|
||||
double precision, intent(in) :: comb
|
||||
logical, intent(inout) :: computed(N_det_generators)
|
||||
integer, intent(inout) :: tbc(0:stbc)
|
||||
integer :: i, k, l, dets(ct)
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call get_comb(comb, dets, ct)
|
||||
|
||||
k=tbc(0)+1
|
||||
do i = 1, ct
|
||||
l = dets(i)
|
||||
if(.not.(computed(l))) then
|
||||
tbc(k) = l
|
||||
k = k+1
|
||||
computed(l) = .true.
|
||||
end if
|
||||
pt2_n_0(pt2_N_teeth+1) = N_det_generators
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
|
||||
do t=1, pt2_N_teeth
|
||||
tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t))
|
||||
if (tooth_width == 0.d0) then
|
||||
tooth_width = sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1)))
|
||||
endif
|
||||
ASSERT(tooth_width > 0.d0)
|
||||
do i=pt2_n_0(t)+1, pt2_n_0(t+1)
|
||||
pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
|
||||
end do
|
||||
end do
|
||||
tbc(0) = k-1
|
||||
end subroutine
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! State for stochatsic PT2
|
||||
END_DOC
|
||||
pt2_stoch_istate = 1
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pt2_weight, (N_det_generators) ]
|
||||
&BEGIN_PROVIDER [ double precision, pt2_cweight, (N_det_generators) ]
|
||||
&BEGIN_PROVIDER [ double precision, pt2_cweight_cache, (N_det_generators) ]
|
||||
&BEGIN_PROVIDER [ double precision, comb_step ]
|
||||
&BEGIN_PROVIDER [ integer, first_det_of_teeth, (comb_teeth+1) ]
|
||||
&BEGIN_PROVIDER [ integer, first_det_of_comb ]
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision :: norm_left, stato
|
||||
integer, external :: pt2_find
|
||||
|
||||
pt2_weight(1) = psi_coef_generators(1,pt2_stoch_istate)**2
|
||||
pt2_cweight(1) = psi_coef_generators(1,pt2_stoch_istate)**2
|
||||
|
||||
pt2_cW(0) = 0d0
|
||||
do i=1,N_det_generators
|
||||
pt2_weight(i) = psi_coef_generators(i,pt2_stoch_istate)**2
|
||||
enddo
|
||||
|
||||
! Important to loop backwards for numerical precision
|
||||
pt2_cweight(N_det_generators) = pt2_weight(N_det_generators)
|
||||
do i=N_det_generators-1,1,-1
|
||||
pt2_cweight(i) = pt2_weight(i) + pt2_cweight(i+1)
|
||||
pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
|
||||
end do
|
||||
|
||||
do i=1,N_det_generators
|
||||
pt2_weight(i) = pt2_weight(i) / pt2_cweight(1)
|
||||
pt2_cweight(i) = pt2_cweight(i) / pt2_cweight(1)
|
||||
enddo
|
||||
|
||||
do i=1,N_det_generators-1
|
||||
pt2_cweight(i) = 1.d0 - pt2_cweight(i+1)
|
||||
end do
|
||||
pt2_cweight(N_det_generators) = 1.d0
|
||||
|
||||
norm_left = 1d0
|
||||
|
||||
comb_step = 1d0/dfloat(comb_teeth)
|
||||
first_det_of_comb = 1
|
||||
do i=1,N_det_generators
|
||||
if(pt2_weight(i)/norm_left < .5d0*comb_step) then
|
||||
first_det_of_comb = i
|
||||
exit
|
||||
end if
|
||||
norm_left -= pt2_weight(i)
|
||||
end do
|
||||
first_det_of_comb = max(2,first_det_of_comb)
|
||||
call write_int(6, first_det_of_comb-1, 'Size of deterministic set')
|
||||
|
||||
comb_step = (1d0 - pt2_cweight(first_det_of_comb-1)) * comb_step
|
||||
|
||||
stato = 1d0 - comb_step
|
||||
iloc = N_det_generators
|
||||
do i=comb_teeth, 1, -1
|
||||
integer :: iloc
|
||||
iloc = pt2_find(stato, pt2_cweight, N_det_generators, 1, iloc)
|
||||
first_det_of_teeth(i) = iloc
|
||||
stato -= comb_step
|
||||
end do
|
||||
first_det_of_teeth(comb_teeth+1) = N_det_generators + 1
|
||||
first_det_of_teeth(1) = first_det_of_comb
|
||||
if(first_det_of_teeth(1) /= first_det_of_comb) then
|
||||
print *, 'Error in ', irp_here
|
||||
stop "comb provider"
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pt2_weight_inv, (N_det_generators) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Inverse of pt2_weight array
|
||||
END_DOC
|
||||
integer :: i
|
||||
do i=1,N_det_generators
|
||||
pt2_weight_inv(i) = 1.d0/pt2_weight(i)
|
||||
enddo
|
||||
|
||||
pt2_n_0(pt2_N_teeth+1) = N_det_generators
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -22,12 +22,11 @@ subroutine run_pt2_slave(thread,iproc,energy)
|
|||
logical :: done
|
||||
|
||||
double precision,allocatable :: pt2(:,:)
|
||||
integer :: n_tasks, k, n_tasks_max
|
||||
integer :: n_tasks, k
|
||||
integer, allocatable :: i_generator(:), subset(:)
|
||||
|
||||
n_tasks_max = N_det_generators/100+1
|
||||
allocate(task_id(n_tasks_max), task(n_tasks_max))
|
||||
allocate(pt2(N_states,n_tasks_max), i_generator(n_tasks_max), subset(n_tasks_max))
|
||||
allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max))
|
||||
allocate(pt2(N_states,pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max))
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
|
||||
|
|
@ -47,7 +46,7 @@ subroutine run_pt2_slave(thread,iproc,energy)
|
|||
do while (.not.done)
|
||||
|
||||
n_tasks = max(1,n_tasks)
|
||||
n_tasks = min(n_tasks,n_tasks_max)
|
||||
n_tasks = min(n_tasks,pt2_n_tasks_max)
|
||||
|
||||
integer, external :: get_tasks_from_taskserver
|
||||
if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
|
||||
|
|
@ -66,7 +65,7 @@ subroutine run_pt2_slave(thread,iproc,energy)
|
|||
do k=1,n_tasks
|
||||
pt2(:,k) = 0.d0
|
||||
buf%cur = 0
|
||||
call select_connected(i_generator(k),energy,pt2(1,k),buf,subset(k))
|
||||
call select_connected(i_generator(k),energy,pt2(1,k),buf,subset(k),pt2_F(i_generator(k)))
|
||||
enddo
|
||||
call wall_time(time1)
|
||||
|
||||
|
|
@ -78,7 +77,6 @@ subroutine run_pt2_slave(thread,iproc,energy)
|
|||
|
||||
! Try to adjust n_tasks around 1 second per job
|
||||
n_tasks = min(n_tasks,int( 1.d0*dble(n_tasks) / (time1 - time0 + 1.d-9)))+1
|
||||
! n_tasks = n_tasks+1
|
||||
end do
|
||||
|
||||
integer, external :: disconnect_from_taskserver
|
||||
|
|
@ -201,12 +199,5 @@ IRP_ENDIF
|
|||
|
||||
end subroutine
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pt2_workload, (N_det_generators) ]
|
||||
integer :: i
|
||||
do i=1,N_det_generators
|
||||
pt2_workload(i) = dfloat(N_det_generators - i + 1)**2
|
||||
end do
|
||||
pt2_workload = pt2_workload / sum(pt2_workload)
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,122 +1,4 @@
|
|||
subroutine run_selection_slave(thread,iproc,energy)
|
||||
implicit none
|
||||
integer, intent(in) :: thread, iproc
|
||||
double precision, intent(in) :: energy(N_states_diag)
|
||||
call run_selection_slave_new(thread,iproc,energy)
|
||||
end
|
||||
|
||||
subroutine run_selection_slave_new(thread,iproc,energy)
|
||||
use f77_zmq
|
||||
use selection_types
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: thread, iproc
|
||||
double precision, intent(in) :: energy(N_states_diag)
|
||||
integer :: rc, i, N
|
||||
logical :: buffer_ready
|
||||
|
||||
integer :: worker_id, ltask
|
||||
character*(512), allocatable :: task(:)
|
||||
integer, allocatable :: task_id(:)
|
||||
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_push_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_push
|
||||
|
||||
type(selection_buffer) :: buf, buf2
|
||||
logical :: done
|
||||
|
||||
double precision,allocatable :: pt2(:,:)
|
||||
integer :: n_tasks, k, n_tasks_max
|
||||
integer, allocatable :: i_generator(:), subset(:)
|
||||
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order
|
||||
|
||||
buffer_ready = .False.
|
||||
n_tasks_max = N_det_generators/100+1
|
||||
allocate(task_id(n_tasks_max), task(n_tasks_max))
|
||||
allocate(pt2(N_states,n_tasks_max), i_generator(n_tasks_max), subset(n_tasks_max))
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
|
||||
integer, external :: connect_to_taskserver
|
||||
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
return
|
||||
endif
|
||||
|
||||
zmq_socket_push = new_zmq_push_socket(thread)
|
||||
|
||||
buf%N = 0
|
||||
n_tasks = 1
|
||||
call create_selection_buffer(0, 0, buf)
|
||||
done = .False.
|
||||
do while (.not.done)
|
||||
|
||||
n_tasks = max(1,n_tasks)
|
||||
n_tasks = min(n_tasks,n_tasks_max)
|
||||
|
||||
integer, external :: get_tasks_from_taskserver
|
||||
if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
|
||||
exit
|
||||
endif
|
||||
done = task_id(n_tasks) == 0
|
||||
if (done) n_tasks = n_tasks-1
|
||||
if (n_tasks == 0) exit
|
||||
|
||||
do k=1,n_tasks
|
||||
read (task(k),*) subset(k), i_generator(k), N
|
||||
enddo
|
||||
|
||||
if(buf%N == 0) then
|
||||
! Only first time
|
||||
call create_selection_buffer(N, N*2, buf)
|
||||
call create_selection_buffer(N, N*2, buf2)
|
||||
buffer_ready = .True.
|
||||
endif
|
||||
|
||||
double precision :: time0, time1
|
||||
call wall_time(time0)
|
||||
do k=1,n_tasks
|
||||
pt2(:,k) = 0.d0
|
||||
buf%cur = 0
|
||||
call select_connected(i_generator(k),energy,pt2(1,k),buf,subset(k))
|
||||
enddo
|
||||
call wall_time(time1)
|
||||
|
||||
integer, external :: tasks_done_to_taskserver
|
||||
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
|
||||
done = .true.
|
||||
endif
|
||||
call sort_selection_buffer(buf)
|
||||
call merge_selection_buffers(buf,buf2)
|
||||
call push_selection_results(zmq_socket_push, pt2, buf, task_id, n_tasks)
|
||||
buf%mini = buf2%mini
|
||||
pt2(:,:) = 0d0
|
||||
buf%cur = 0
|
||||
|
||||
! ! Try to adjust n_tasks around 5 second per job
|
||||
! n_tasks = min(n_tasks,int( 5.d0 * dble(n_tasks) / (time1 - time0 + 1.d-9)))+1
|
||||
n_tasks = n_tasks+1
|
||||
end do
|
||||
|
||||
integer, external :: disconnect_from_taskserver
|
||||
if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
continue
|
||||
endif
|
||||
|
||||
call end_zmq_push_socket(zmq_socket_push,thread)
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
call delete_selection_buffer(buf)
|
||||
|
||||
end
|
||||
|
||||
subroutine run_selection_slave_old(thread,iproc,energy)
|
||||
use f77_zmq
|
||||
use selection_types
|
||||
implicit none
|
||||
|
|
@ -177,7 +59,7 @@ subroutine run_selection_slave_old(thread,iproc,energy)
|
|||
else
|
||||
ASSERT (N == buf%N)
|
||||
end if
|
||||
call select_connected(i_generator,energy,pt2,buf,subset)
|
||||
call select_connected(i_generator,energy,pt2,buf,subset,pt2_F(i_generator))
|
||||
endif
|
||||
|
||||
integer, external :: task_done_to_taskserver
|
||||
|
|
|
|||
|
|
@ -1,14 +1,5 @@
|
|||
use bitmasks
|
||||
|
||||
BEGIN_PROVIDER [ integer, fragment_count ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of fragments for the deterministic part
|
||||
END_DOC
|
||||
fragment_count = (elec_alpha_num-n_core_orb)**2
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine assert(cond, msg)
|
||||
character(*), intent(in) :: msg
|
||||
logical, intent(in) :: cond
|
||||
|
|
@ -46,11 +37,11 @@ subroutine get_mask_phase(det, phasemask)
|
|||
end subroutine
|
||||
|
||||
|
||||
subroutine select_connected(i_generator,E0,pt2,b,subset)
|
||||
subroutine select_connected(i_generator,E0,pt2,b,subset,csubset)
|
||||
use bitmasks
|
||||
use selection_types
|
||||
implicit none
|
||||
integer, intent(in) :: i_generator, subset
|
||||
integer, intent(in) :: i_generator, subset, csubset
|
||||
type(selection_buffer), intent(inout) :: b
|
||||
double precision, intent(inout) :: pt2(N_states)
|
||||
integer :: k,l
|
||||
|
|
@ -71,7 +62,7 @@ subroutine select_connected(i_generator,E0,pt2,b,subset)
|
|||
particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) )
|
||||
particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) )
|
||||
enddo
|
||||
call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset)
|
||||
call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset,csubset)
|
||||
enddo
|
||||
deallocate(fock_diag_tmp)
|
||||
end subroutine
|
||||
|
|
@ -266,7 +257,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
|
|||
end
|
||||
|
||||
|
||||
subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset)
|
||||
subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset,csubset)
|
||||
use bitmasks
|
||||
use selection_types
|
||||
implicit none
|
||||
|
|
@ -274,7 +265,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
|||
! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
|
||||
END_DOC
|
||||
|
||||
integer, intent(in) :: i_generator, subset
|
||||
integer, intent(in) :: i_generator, subset, csubset
|
||||
integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2)
|
||||
double precision, intent(in) :: fock_diag_tmp(mo_tot_num)
|
||||
double precision, intent(in) :: E0(N_states)
|
||||
|
|
@ -298,8 +289,6 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
|||
integer(bit_kind), allocatable:: preinteresting_det(:,:,:)
|
||||
allocate (preinteresting_det(N_int,2,N_det))
|
||||
|
||||
PROVIDE fragment_count
|
||||
|
||||
monoAdo = .true.
|
||||
monoBdo = .true.
|
||||
|
||||
|
|
@ -571,7 +560,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
|||
end if
|
||||
|
||||
maskInd += 1
|
||||
if(subset == 0 .or. mod(maskInd, fragment_count) == (subset-1)) then
|
||||
if(mod(maskInd, csubset) == (subset-1)) then
|
||||
|
||||
call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting)
|
||||
if(fullMatch) cycle
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ end
|
|||
|
||||
subroutine provide_everything
|
||||
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context n_states_diag
|
||||
PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count ci_energy mpi_master zmq_state zmq_context
|
||||
PROVIDE pt2_e0_denominator mo_tot_num N_int ci_energy mpi_master zmq_state zmq_context
|
||||
PROVIDE psi_det psi_coef
|
||||
end
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ end
|
|||
|
||||
subroutine provide_everything
|
||||
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context n_states_diag
|
||||
PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count ci_energy mpi_master zmq_state zmq_context
|
||||
PROVIDE pt2_e0_denominator mo_tot_num N_int ci_energy mpi_master zmq_state zmq_context
|
||||
PROVIDE psi_det psi_coef
|
||||
end
|
||||
|
||||
|
|
|
|||
|
|
@ -12,15 +12,13 @@ subroutine ZMQ_selection(N_in, pt2)
|
|||
double precision, intent(out) :: pt2(N_states)
|
||||
|
||||
|
||||
PROVIDE fragment_count
|
||||
|
||||
N = max(N_in,1)
|
||||
if (.True.) then
|
||||
PROVIDE pt2_e0_denominator nproc
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order fragment_count
|
||||
PROVIDE psi_bilinear_matrix_transp_order
|
||||
|
||||
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')
|
||||
|
||||
|
|
@ -60,9 +58,8 @@ subroutine ZMQ_selection(N_in, pt2)
|
|||
task = ' '
|
||||
|
||||
do i= 1, N_det_generators
|
||||
! /!\ Fragments don't work
|
||||
! if (i>-ishft(N_det_generators,-2)) then
|
||||
write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') 0, i, N
|
||||
do j=1,pt2_F(pt2_J(i))
|
||||
write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N
|
||||
ipos += 30
|
||||
if (ipos > 63970) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
|
|
@ -70,18 +67,7 @@ subroutine ZMQ_selection(N_in, pt2)
|
|||
endif
|
||||
ipos=1
|
||||
endif
|
||||
! else
|
||||
! do j=1,fragment_count
|
||||
! write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, i, N
|
||||
! ipos += 30
|
||||
! if (ipos > 63970) then
|
||||
! if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
! stop 'Unable to add task to task server'
|
||||
! endif
|
||||
! ipos=1
|
||||
! endif
|
||||
! end do
|
||||
! endif
|
||||
end do
|
||||
enddo
|
||||
if (ipos > 1) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
|
|||
N_det_generators = N_det
|
||||
do i=1,N_det
|
||||
norm = norm + psi_average_norm_contrib_sorted(i)
|
||||
if (norm >= threshold_generators) then
|
||||
if (norm > threshold_generators+1d-10) then
|
||||
N_det_generators = i
|
||||
exit
|
||||
endif
|
||||
|
|
@ -29,7 +29,6 @@ END_PROVIDER
|
|||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
integer :: i, k
|
||||
psi_det_generators(1:N_int,1:2,1:N_det) = psi_det_sorted(1:N_int,1:2,1:N_det)
|
||||
psi_coef_generators(1:N_det,1:N_states) = psi_coef_sorted(1:N_det,1:N_states)
|
||||
|
||||
|
|
@ -44,7 +43,6 @@ END_PROVIDER
|
|||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
integer :: i, k
|
||||
psi_det_sorted_gen = psi_det_sorted
|
||||
psi_coef_sorted_gen = psi_coef_sorted
|
||||
psi_det_sorted_gen_order = psi_det_sorted_order
|
||||
|
|
|
|||
|
|
@ -17,12 +17,6 @@ doc: Stop stochastic PT2 when the relative error is smaller than PT2_relative_er
|
|||
interface: ezfio,provider,ocaml
|
||||
default: 0.001
|
||||
|
||||
[PT2_absolute_error]
|
||||
type: Threshold
|
||||
doc: Stop stochastic PT2 when the statistical error is smaller than PT2_absolute_error
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.00001
|
||||
|
||||
[correlation_energy_ratio_max]
|
||||
type: Normalized_float
|
||||
doc: The selection process stops at a fixed correlation ratio (useful for getting same accuracy between molecules)
|
||||
|
|
|
|||
|
|
@ -10,3 +10,9 @@ doc: Maximum number of dressed CI iterations
|
|||
interface: ezfio,provider,ocaml
|
||||
default: 10
|
||||
|
||||
[dress_relative_error]
|
||||
type: Normalized_float
|
||||
doc: Stop stochastic PT2 when the relative error is smaller than PT2_relative_error
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.001
|
||||
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@ use bitmasks
|
|||
|
||||
|
||||
|
||||
subroutine alpha_callback(delta_ij_loc, i_generator, subset,iproc)
|
||||
subroutine alpha_callback(delta_ij_loc, i_generator, subset, csubset, iproc)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer, intent(in) :: i_generator, subset
|
||||
integer, intent(in) :: i_generator, subset, csubset
|
||||
double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2)
|
||||
integer, intent(in) :: iproc
|
||||
|
||||
|
|
@ -15,7 +15,7 @@ subroutine alpha_callback(delta_ij_loc, i_generator, subset,iproc)
|
|||
|
||||
|
||||
do l=1,N_generators_bitmask
|
||||
call generate_singles_and_doubles(delta_ij_loc, i_generator,l,subset,iproc)
|
||||
call generate_singles_and_doubles(delta_ij_loc,i_generator,l,subset,csubset,iproc)
|
||||
enddo
|
||||
end subroutine
|
||||
|
||||
|
|
@ -34,7 +34,7 @@ BEGIN_PROVIDER [ integer, psi_from_sorted_gen, (N_det) ]
|
|||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index, subset, iproc)
|
||||
subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index, subset, csubset, iproc)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
|
@ -42,7 +42,7 @@ subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index
|
|||
END_DOC
|
||||
|
||||
double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2)
|
||||
integer, intent(in) :: i_generator, subset, bitmask_index
|
||||
integer, intent(in) :: i_generator, subset, csubset, bitmask_index
|
||||
integer, intent(in) :: iproc
|
||||
|
||||
|
||||
|
|
@ -66,11 +66,11 @@ subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index
|
|||
integer(bit_kind), allocatable:: preinteresting_det(:,:,:)
|
||||
integer ,allocatable :: abuf(:), labuf(:)
|
||||
|
||||
allocate(abuf(0:N_det*6), labuf(0:N_det))
|
||||
allocate(abuf(N_det*6), labuf(N_det))
|
||||
allocate(preinteresting_det(N_int,2,N_det))
|
||||
|
||||
PROVIDE fragment_count
|
||||
|
||||
maskInd = -1
|
||||
|
||||
monoAdo = .true.
|
||||
monoBdo = .true.
|
||||
|
|
@ -193,7 +193,6 @@ subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index
|
|||
allocate(counted(mo_tot_num, mo_tot_num), countedOrb(mo_tot_num, 2))
|
||||
allocate (indexes(0:mo_tot_num, 0:mo_tot_num))
|
||||
allocate (indexes_end(0:mo_tot_num, 0:mo_tot_num))
|
||||
maskInd = -1
|
||||
integer :: nb_count
|
||||
do s1=1,2
|
||||
do i1=N_holes(s1),1,-1 ! Generate low excitations first
|
||||
|
|
@ -345,7 +344,7 @@ subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index
|
|||
end if
|
||||
|
||||
maskInd += 1
|
||||
if(subset == 0 .or. mod(maskInd, fragment_count) == (subset-1)) then
|
||||
if(mod(maskInd, csubset) == (subset-1)) then
|
||||
|
||||
call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting)
|
||||
if(fullMatch) cycle
|
||||
|
|
@ -387,7 +386,7 @@ subroutine alpha_callback_mask(delta_ij_loc, i_gen, sp, mask, bannedOrb, banned,
|
|||
integer(bit_kind), allocatable :: det_minilist(:,:,:)
|
||||
|
||||
|
||||
allocate(abuf(0:siz), labuf(0:N_det), putten(N_det), det_minilist(N_int, 2, N_det))
|
||||
allocate(abuf(siz), labuf(N_det), putten(N_det), det_minilist(N_int, 2, N_det))
|
||||
|
||||
do i=1,siz
|
||||
abuf(i) = psi_from_sorted_gen(rabuf(i))
|
||||
|
|
@ -638,7 +637,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, indexes, ab
|
|||
integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel)
|
||||
logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2)
|
||||
integer, intent(inout) :: indexes(0:mo_tot_num, 0:mo_tot_num)
|
||||
integer, intent(inout) :: abuf(0:*)
|
||||
integer, intent(inout) :: abuf(*)
|
||||
integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt, s
|
||||
integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
|
||||
integer :: phasemask(2,N_int*bit_kind_size)
|
||||
|
|
@ -704,7 +703,7 @@ subroutine get_d2(i_gen, gen, banned, bannedOrb, indexes, abuf, mask, h, p, sp)
|
|||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
|
||||
integer, intent(inout) :: abuf(0:*)
|
||||
integer, intent(inout) :: abuf(*)
|
||||
integer, intent(in) :: i_gen
|
||||
logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2)
|
||||
integer, intent(inout) :: indexes(0:mo_tot_num, 0:mo_tot_num)
|
||||
|
|
@ -832,7 +831,7 @@ subroutine get_d1(i_gen, gen, banned, bannedOrb, indexes, abuf, mask, h, p, sp)
|
|||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
|
||||
integer, intent(inout) :: abuf(0:*)
|
||||
integer, intent(inout) :: abuf(*)
|
||||
integer,intent(in) :: i_gen
|
||||
logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2)
|
||||
integer(bit_kind) :: det(N_int, 2)
|
||||
|
|
|
|||
|
|
@ -29,8 +29,6 @@ subroutine run_dressing(N_st,energy)
|
|||
delta_E = 1.d0
|
||||
iteration = 0
|
||||
do iteration=1,n_it_dress_max
|
||||
N_det_delta_ij = N_det
|
||||
touch N_det_delta_ij
|
||||
print *, '==============================================='
|
||||
print *, 'Iteration', iteration, '/', n_it_dress_max
|
||||
print *, '==============================================='
|
||||
|
|
@ -40,13 +38,11 @@ subroutine run_dressing(N_st,energy)
|
|||
do i=1,N_st
|
||||
print *, i, psi_energy(i)+nuclear_repulsion
|
||||
enddo
|
||||
!print *, "DELTA IJ", delta_ij(1,1,1)
|
||||
PROVIDE delta_ij_tmp
|
||||
if(.true.) call delta_ij_done()
|
||||
print *, 'Dressed energy <Psi|H+Delta|Psi>'
|
||||
do i=1,N_st
|
||||
print *, i, ci_energy_dressed(i)
|
||||
enddo
|
||||
energy(1:N_st) = ci_energy_dressed(1:N_st)
|
||||
call diagonalize_ci_dressed
|
||||
E_new = sum(psi_energy(:))
|
||||
|
||||
|
|
@ -56,7 +52,6 @@ subroutine run_dressing(N_st,energy)
|
|||
call write_double(6,delta_E,"delta_E (undressed)")
|
||||
delta_E = dabs(delta_E)
|
||||
call save_wavefunction
|
||||
! call ezfio_set_dress_zmq_energy(ci_energy_dressed(1))
|
||||
if (delta_E < thresh_dress) then
|
||||
exit
|
||||
endif
|
||||
|
|
@ -67,10 +62,9 @@ subroutine run_dressing(N_st,energy)
|
|||
enddo
|
||||
print *, 'Dressed energy <Psi|H+Delta|Psi>'
|
||||
do i=1,N_st
|
||||
print *, i, ci_energy_dressed(i)+nuclear_repulsion
|
||||
print *, i, ci_energy_dressed(i)
|
||||
enddo
|
||||
endif
|
||||
|
||||
if(.true.) energy(1:N_st) = 0d0 ! ci_energy_dressed(1:N_st)
|
||||
end
|
||||
|
||||
|
|
|
|||
|
|
@ -50,9 +50,7 @@ subroutine run_wf
|
|||
else if (zmq_state(:5) == 'dress') then
|
||||
! Dress
|
||||
! ---------
|
||||
!call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
|
||||
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
|
||||
!TOUCH psi_det
|
||||
if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle
|
||||
if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle
|
||||
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle
|
||||
|
|
@ -60,7 +58,7 @@ subroutine run_wf
|
|||
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'dress_stoch_istate',tmp,1) == -1) cycle
|
||||
dress_stoch_istate = int(tmp)
|
||||
psi_energy(1:N_states) = energy(1:N_states)
|
||||
TOUCH psi_energy dress_stoch_istate state_average_weight
|
||||
TOUCH psi_energy dress_stoch_istate state_average_weight
|
||||
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_gen_order psi_bilinear_matrix_order
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,71 +1,9 @@
|
|||
use bitmasks
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, N_dress_teeth ]
|
||||
N_dress_teeth = 10
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, dress_norm_acc, (0:N_det, N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, dress_norm, (0:N_det, N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, dress_teeth_size, (0:N_det, N_states) ]
|
||||
&BEGIN_PROVIDER [ integer, dress_teeth, (0:N_dress_teeth+1, N_states) ]
|
||||
implicit none
|
||||
integer :: i, j, st, nt
|
||||
double precision :: norm_sto, jump, norm_mwen, norm_loc
|
||||
|
||||
if(N_states /= 1) stop "dress_sto may not work with N_states /= 1"
|
||||
|
||||
do st=1,N_states
|
||||
dress_teeth(0,st) = 1
|
||||
norm_sto = 1d0
|
||||
do i=1,N_det
|
||||
dress_teeth(1,st) = i
|
||||
jump = (1d0 / dfloat(N_dress_teeth)) * norm_sto
|
||||
if(psi_coef_generators(i,1)**2 < jump / 2d0) exit
|
||||
norm_sto -= psi_coef_generators(i,1)**2
|
||||
end do
|
||||
|
||||
norm_loc = 0d0
|
||||
dress_norm_acc(0,st) = 0d0
|
||||
nt = 1
|
||||
|
||||
do i=1,dress_teeth(1,st)-1
|
||||
dress_norm_acc(i,st) = dress_norm_acc(i-1,st) + psi_coef_generators(i,st)**2
|
||||
end do
|
||||
|
||||
do i=dress_teeth(1,st), N_det_generators!-dress_teeth(1,st)+1
|
||||
norm_mwen = psi_coef_generators(i,st)**2!-1+dress_teeth(1,st),st)**2
|
||||
dress_norm_acc(i,st) = dress_norm_acc(i-1,st) + norm_mwen
|
||||
norm_loc += norm_mwen
|
||||
if(norm_loc > (jump*dfloat(nt))) then
|
||||
nt = nt + 1
|
||||
dress_teeth(nt,st) = i
|
||||
end if
|
||||
end do
|
||||
if(nt > N_dress_teeth+1) then
|
||||
print *, "foireouse dress_teeth", nt, dress_teeth(nt,st), N_det
|
||||
stop
|
||||
end if
|
||||
|
||||
dress_teeth(N_dress_teeth+1,st) = N_det+1
|
||||
norm_loc = 0d0
|
||||
do i=N_dress_teeth, 0, -1
|
||||
dress_teeth_size(i,st) = dress_norm_acc(dress_teeth(i+1,st)-1,st) - dress_norm_acc(dress_teeth(i,st)-1, st)
|
||||
dress_norm_acc(dress_teeth(i,st):dress_teeth(i+1,st)-1,st) -= dress_norm_acc(dress_teeth(i,st)-1, st)
|
||||
dress_norm_acc(dress_teeth(i,st):dress_teeth(i+1,st)-1,st) = &
|
||||
dress_norm_acc(dress_teeth(i,st):dress_teeth(i+1,st)-1,st) / dress_teeth_size(i,st)
|
||||
dress_norm(dress_teeth(i,st), st) = dress_norm_acc(dress_teeth(i,st), st)
|
||||
do j=dress_teeth(i,st)+1, dress_teeth(i+1,1)-1
|
||||
dress_norm(j,1) = dress_norm_acc(j, st) - dress_norm_acc(j-1, st)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer , N_det_delta_ij ]
|
||||
implicit none
|
||||
N_det_delta_ij = 1
|
||||
N_det_delta_ij = N_det
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, delta_ij, (N_states, N_det, 2) ]
|
||||
|
|
@ -83,36 +21,23 @@ BEGIN_PROVIDER [ double precision, delta_ij_tmp, (N_states,N_det_delta_ij,2) ]
|
|||
integer :: i,j,k
|
||||
|
||||
double precision, allocatable :: dress(:), del(:,:), del_s2(:,:)
|
||||
double precision :: E_CI_before(N_states), relative_error
|
||||
double precision :: E_CI_before(N_states)
|
||||
integer :: cnt = 0
|
||||
|
||||
! prevents re-providing if delta_ij_tmp is
|
||||
! just being copied
|
||||
if(N_det_delta_ij == N_det) then
|
||||
allocate(dress(N_states), del(N_states, N_det_delta_ij), del_s2(N_states, N_det_delta_ij))
|
||||
|
||||
delta_ij_tmp = 0d0
|
||||
|
||||
E_CI_before(:) = dress_E0_denominator(:) + nuclear_repulsion
|
||||
|
||||
call write_double(6,dress_relative_error,"Convergence of the stochastic algorithm")
|
||||
|
||||
allocate(dress(N_states), del(N_states, N_det_delta_ij), del_s2(N_states, N_det_delta_ij))
|
||||
|
||||
delta_ij_tmp = 0d0
|
||||
|
||||
E_CI_before(:) = psi_energy(:) + nuclear_repulsion
|
||||
threshold_selectors = 1.d0
|
||||
threshold_generators = 1.d0
|
||||
SOFT_TOUCH threshold_selectors threshold_generators
|
||||
! if(errr /= 0d0) then
|
||||
! errr = errr / 2d0
|
||||
! else
|
||||
! errr = 1d-4
|
||||
! end if
|
||||
relative_error = 1.d-3
|
||||
|
||||
call write_double(6,relative_error,"Relative error for the stochastic algorithm")
|
||||
|
||||
call ZMQ_dress(E_CI_before, dress, del, del_s2, abs(relative_error), N_det_delta_ij)
|
||||
delta_ij_tmp(:,:,1) = del(:,:)
|
||||
delta_ij_tmp(:,:,2) = del_s2(:,:)
|
||||
call ZMQ_dress(E_CI_before, dress, del, del_s2, abs(dress_relative_error), N_det_delta_ij)
|
||||
delta_ij_tmp(:,:,1) = del(:,:)
|
||||
delta_ij_tmp(:,:,2) = del_s2(:,:)
|
||||
|
||||
|
||||
deallocate(dress, del, del_s2)
|
||||
end if
|
||||
deallocate(dress, del, del_s2)
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,5 @@
|
|||
use bitmasks
|
||||
|
||||
BEGIN_PROVIDER [ integer, fragment_count ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of fragments for the deterministic part
|
||||
END_DOC
|
||||
fragment_count = 1
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine run_dress_slave(thread,iproce,energy)
|
||||
use f77_zmq
|
||||
|
|
@ -16,81 +8,75 @@ subroutine run_dress_slave(thread,iproce,energy)
|
|||
|
||||
double precision, intent(in) :: energy(N_states_diag)
|
||||
integer, intent(in) :: thread, iproce
|
||||
integer :: rc, i, subset, i_generator
|
||||
integer :: rc, i, j, subset, i_generator
|
||||
|
||||
integer :: worker_id, task_id, ctask, ltask
|
||||
character*(5120) :: task
|
||||
integer :: worker_id, ctask, ltask
|
||||
character*(512) :: task(Nproc)
|
||||
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_push_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_push
|
||||
|
||||
logical :: done
|
||||
|
||||
double precision,allocatable :: dress_detail(:)
|
||||
integer :: ind
|
||||
|
||||
double precision,allocatable :: delta_ij_loc(:,:,:)
|
||||
integer :: h,p,n,i_state
|
||||
logical :: ok
|
||||
|
||||
integer, allocatable :: int_buf(:)
|
||||
double precision, allocatable :: double_buf(:)
|
||||
integer(bit_kind), allocatable :: det_buf(:,:,:)
|
||||
integer :: N_buf(3)
|
||||
logical :: last
|
||||
double precision,allocatable :: breve_delta_m(:,:,:)
|
||||
integer :: i_state,m,l,t,p,sum_f
|
||||
!integer, external :: omp_get_thread_num
|
||||
double precision, allocatable :: delta_det(:,:,:,:), cp(:,:,:,:)
|
||||
integer :: toothMwen
|
||||
logical :: fracted
|
||||
double precision, allocatable :: delta_det(:,:,:,:), cp(:,:,:,:), edI(:)
|
||||
double precision, allocatable :: edI_task(:)
|
||||
integer, allocatable :: edI_index(:), edI_taskID(:)
|
||||
integer :: n_tasks
|
||||
|
||||
integer :: iproc
|
||||
integer, allocatable :: f(:)
|
||||
integer :: cp_sent, cp_done
|
||||
integer :: cp_max(Nproc)
|
||||
integer :: will_send, task_id, purge_task_id, ntask_buf
|
||||
integer, allocatable :: task_buf(:)
|
||||
integer(kind=OMP_LOCK_KIND) :: lck_det(0:pt2_N_teeth+1)
|
||||
integer(kind=OMP_LOCK_KIND) :: lck_sto(0:dress_N_cp+1), sending, getting_task
|
||||
double precision :: fac
|
||||
|
||||
|
||||
double precision :: ending(1)
|
||||
integer, external :: zmq_get_dvector
|
||||
! double precision, external :: omp_get_wtime
|
||||
double precision :: time, time0
|
||||
integer :: ntask_tbd, task_tbd(Nproc), i_gen_tbd(Nproc), subset_tbd(Nproc)
|
||||
! if(iproce /= 0) stop "RUN DRESS SLAVE is OMP"
|
||||
|
||||
allocate(delta_det(N_states, N_det, 0:comb_teeth+1, 2))
|
||||
allocate(cp(N_states, N_det, N_cp, 2))
|
||||
delta_det = 0d9
|
||||
allocate(delta_det(N_states, N_det, 0:pt2_N_teeth+1, 2))
|
||||
allocate(cp(N_states, N_det, dress_N_cp, 2))
|
||||
allocate(edI(N_det_generators), f(N_det_generators))
|
||||
allocate(edI_index(N_det_generators), edI_task(N_det_generators))
|
||||
edI = 0d0
|
||||
f = 0
|
||||
delta_det = 0d0
|
||||
cp = 0d0
|
||||
|
||||
task = CHAR(0)
|
||||
|
||||
task(:) = CHAR(0)
|
||||
|
||||
|
||||
|
||||
integer :: iproc, cur_cp, done_for(0:N_cp)
|
||||
integer, allocatable :: tasks(:)
|
||||
integer :: lastCp(Nproc)
|
||||
integer :: lastSent, lastSendable
|
||||
logical :: send
|
||||
integer(kind=OMP_LOCK_KIND) :: lck_det(0:comb_teeth+1)
|
||||
integer(kind=OMP_LOCK_KIND) :: lck_sto(0:N_cp+1)
|
||||
|
||||
do i=0,N_cp+1
|
||||
call omp_init_lock(sending)
|
||||
call omp_init_lock(getting_task)
|
||||
do i=0,dress_N_cp+1
|
||||
call omp_init_lock(lck_sto(i))
|
||||
end do
|
||||
do i=0,comb_teeth+1
|
||||
do i=0,pt2_N_teeth+1
|
||||
call omp_init_lock(lck_det(i))
|
||||
end do
|
||||
|
||||
lastCp = 0
|
||||
lastSent = 0
|
||||
send = .false.
|
||||
done_for = 0
|
||||
|
||||
double precision :: hij, sij
|
||||
!call i_h_j_s2(psi_det(1,1,1),psi_det(1,1,2),N_int,hij, sij)
|
||||
|
||||
hij = dress_E0_denominator(1) !PROVIDE BEFORE OMP PARALLEL
|
||||
cp_done = 0
|
||||
cp_sent = 0
|
||||
will_send = 0
|
||||
|
||||
double precision :: hij, sij, tmp
|
||||
purge_task_id = 0
|
||||
provide psi_energy
|
||||
ending(1) = dble(dress_N_cp+1)
|
||||
ntask_tbd = 0
|
||||
!$OMP PARALLEL DEFAULT(SHARED) &
|
||||
!$OMP PRIVATE(int_buf, double_buf, det_buf, delta_ij_loc, task, task_id) &
|
||||
!$OMP PRIVATE(lastSendable, toothMwen, fracted, fac) &
|
||||
!$OMP PRIVATE(i, cur_cp, send, i_generator, subset, iproc, N_buf) &
|
||||
!$OMP PRIVATE(zmq_to_qp_run_socket, zmq_socket_push, worker_id)
|
||||
|
||||
!$OMP PRIVATE(breve_delta_m, task_id) &
|
||||
!$OMP PRIVATE(tmp,fac,m,l,t,sum_f,n_tasks) &
|
||||
!$OMP PRIVATE(i,p,will_send, i_generator, subset, iproc) &
|
||||
!$OMP PRIVATE(zmq_to_qp_run_socket, zmq_socket_push, worker_id) &
|
||||
!$OMP PRIVATE(task_buf, ntask_buf,time, time0)
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
zmq_socket_push = new_zmq_push_socket(thread)
|
||||
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
|
||||
|
|
@ -99,276 +85,247 @@ subroutine run_dress_slave(thread,iproce,energy)
|
|||
call end_zmq_push_socket(zmq_socket_push,thread)
|
||||
stop "WORKER -1"
|
||||
end if
|
||||
|
||||
|
||||
iproc = omp_get_thread_num()+1
|
||||
allocate(int_buf(N_dress_int_buffer))
|
||||
allocate(double_buf(N_dress_double_buffer))
|
||||
allocate(det_buf(N_int, 2, N_dress_det_buffer))
|
||||
allocate(delta_ij_loc(N_states,N_det,2))
|
||||
do
|
||||
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
|
||||
task = task//" 0"
|
||||
if(task_id == 0) exit
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
if(task_id /= 0) then
|
||||
read (task,*) subset, i_generator
|
||||
allocate(breve_delta_m(N_states,N_det,2))
|
||||
allocate(task_buf(pt2_n_tasks_max))
|
||||
ntask_buf = 0
|
||||
|
||||
if(iproc==1) then
|
||||
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, task_buf, ntask_buf)
|
||||
end if
|
||||
|
||||
!$OMP ATOMIC
|
||||
done_for(done_cp_at_det(i_generator)) += 1
|
||||
! print *, "IGEN", i_generator, done_cp_at_det(i_generator)
|
||||
delta_ij_loc(:,:,:) = 0d0
|
||||
call generator_start(i_generator, iproc)
|
||||
call alpha_callback(delta_ij_loc, i_generator, subset, iproc)
|
||||
call generator_done(i_generator, int_buf, double_buf, det_buf, N_buf, iproc)
|
||||
|
||||
do i=1,N_cp
|
||||
fac = cps(i_generator, i) * dress_weight_inv(i_generator) * comb_step
|
||||
if(fac == 0d0) cycle
|
||||
call omp_set_lock(lck_sto(i))
|
||||
cp(:,:,i,1) += (delta_ij_loc(:,:,1) * fac)
|
||||
cp(:,:,i,2) += (delta_ij_loc(:,:,2) * fac)
|
||||
call omp_unset_lock(lck_sto(i))
|
||||
end do
|
||||
|
||||
|
||||
toothMwen = tooth_of_det(i_generator)
|
||||
fracted = (toothMwen /= 0)
|
||||
if(fracted) fracted = (i_generator == first_det_of_teeth(toothMwen))
|
||||
if(fracted) then
|
||||
call omp_set_lock(lck_det(toothMwen))
|
||||
call omp_set_lock(lck_det(toothMwen-1))
|
||||
delta_det(:,:,toothMwen-1, 1) += delta_ij_loc(:,:,1) * (1d0-fractage(toothMwen))
|
||||
delta_det(:,:,toothMwen-1, 2) += delta_ij_loc(:,:,2) * (1d0-fractage(toothMwen))
|
||||
delta_det(:,:,toothMwen , 1) += delta_ij_loc(:,:,1) * (fractage(toothMwen))
|
||||
delta_det(:,:,toothMwen , 2) += delta_ij_loc(:,:,2) * (fractage(toothMwen))
|
||||
call omp_unset_lock(lck_det(toothMwen))
|
||||
call omp_unset_lock(lck_det(toothMwen-1))
|
||||
else
|
||||
call omp_set_lock(lck_det(toothMwen))
|
||||
delta_det(:,:,toothMwen , 1) += delta_ij_loc(:,:,1)
|
||||
delta_det(:,:,toothMwen , 2) += delta_ij_loc(:,:,2)
|
||||
call omp_unset_lock(lck_det(toothMwen))
|
||||
end if
|
||||
call push_dress_results(zmq_socket_push, i_generator, -1, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, task_id)
|
||||
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
|
||||
lastCp(iproc) = done_cp_at_det(i_generator)
|
||||
do while(cp_done > cp_sent .or. m /= dress_N_cp+1)
|
||||
call omp_set_lock(getting_task)
|
||||
if(ntask_tbd == 0) then
|
||||
ntask_tbd = size(task_tbd)
|
||||
call get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_tbd, task, ntask_tbd)
|
||||
!task = task//" 0"
|
||||
end if
|
||||
|
||||
|
||||
task_id = task_tbd(1)
|
||||
if(task_id /= 0) then
|
||||
read (task(1),*) subset, i_generator
|
||||
do i=1,size(task_tbd)-1
|
||||
task_tbd(i) = task_tbd(i+1)
|
||||
task(i) = task(i+1)
|
||||
end do
|
||||
m = dress_P(i_generator)
|
||||
ntask_tbd -= 1
|
||||
else
|
||||
m = dress_N_cp + 1
|
||||
i= zmq_get_dvector(zmq_to_qp_run_socket, worker_id, "ending", ending, 1)
|
||||
end if
|
||||
call omp_unset_lock(getting_task)
|
||||
will_send = 0
|
||||
|
||||
!$OMP CRITICAL
|
||||
send = .false.
|
||||
lastSendable = N_cp*2
|
||||
do i=1,Nproc
|
||||
lastSendable = min(lastCp(i), lastSendable)
|
||||
end do
|
||||
lastSendable -= 1
|
||||
if(lastSendable > lastSent .or. (lastSendable == N_cp-1 .and. lastSent /= N_cp-1)) then
|
||||
lastSent = lastSendable
|
||||
cur_cp = lastSent
|
||||
send = .true.
|
||||
cp_max(iproc) = m
|
||||
cp_done = minval(cp_max)-1
|
||||
if(cp_done > cp_sent) then
|
||||
will_send = cp_sent + 1
|
||||
cp_sent = will_send
|
||||
end if
|
||||
if(purge_task_id == 0) then
|
||||
purge_task_id = task_id
|
||||
task_id = 0
|
||||
else if(task_id /= 0) then
|
||||
ntask_buf += 1
|
||||
task_buf(ntask_buf) = task_id
|
||||
end if
|
||||
!$OMP END CRITICAL
|
||||
|
||||
if(send) then
|
||||
N_buf = (/0,1,0/)
|
||||
|
||||
delta_ij_loc = 0d0
|
||||
if(cur_cp < 1) stop "cur_cp < 1"
|
||||
do i=1,cur_cp
|
||||
delta_ij_loc(:,:,1) += cp(:,:,i,1)
|
||||
delta_ij_loc(:,:,2) += cp(:,:,i,2)
|
||||
if(will_send /= 0 .and. will_send <= int(ending(1))) then
|
||||
call omp_set_lock(sending)
|
||||
n_tasks = 0
|
||||
sum_f = 0
|
||||
do i=1,N_det_generators
|
||||
if(dress_P(i) <= will_send) sum_f = sum_f + f(i)
|
||||
if(dress_P(i) == will_send .and. f(i) /= 0) then
|
||||
n_tasks += 1
|
||||
edI_task(n_tasks) = edI(i)
|
||||
edI_index(n_tasks) = i
|
||||
end if
|
||||
end do
|
||||
|
||||
delta_ij_loc(:,:,:) = delta_ij_loc(:,:,:) / cps_N(cur_cp)
|
||||
do i=cp_first_tooth(cur_cp)-1,0,-1
|
||||
delta_ij_loc(:,:,1) = delta_ij_loc(:,:,1) +delta_det(:,:,i,1)
|
||||
delta_ij_loc(:,:,2) = delta_ij_loc(:,:,2) +delta_det(:,:,i,2)
|
||||
end do
|
||||
call push_dress_results(zmq_socket_push, done_for(cur_cp), cur_cp, delta_ij_loc, int_buf, double_buf, det_buf, N_buf, -1)
|
||||
call push_dress_results(zmq_socket_push, will_send, sum_f, edI_task, edI_index, breve_delta_m, 0, n_tasks)
|
||||
call omp_unset_lock(sending)
|
||||
end if
|
||||
|
||||
if(m /= dress_N_cp+1) then
|
||||
!UPDATE i_generator
|
||||
|
||||
if(task_id == 0) exit
|
||||
breve_delta_m(:,:,:) = 0d0
|
||||
call generator_start(i_generator, iproc)
|
||||
time0 = omp_get_wtime()
|
||||
call alpha_callback(breve_delta_m, i_generator, subset, pt2_F(i_generator), iproc)
|
||||
time = omp_get_wtime()
|
||||
!print '(I0.11, I4, A12, F12.3)', i_generator, subset, "GREPMETIME", time-time0
|
||||
t = dress_T(i_generator)
|
||||
|
||||
call omp_set_lock(lck_det(t))
|
||||
do j=1,N_det
|
||||
do i=1,N_states
|
||||
delta_det(i,j,t, 1) = delta_det(i,j,t, 1) + breve_delta_m(i,j,1)
|
||||
delta_det(i,j,t, 2) = delta_det(i,j,t, 2) + breve_delta_m(i,j,2)
|
||||
enddo
|
||||
enddo
|
||||
call omp_unset_lock(lck_det(t))
|
||||
|
||||
do p=1,dress_N_cp
|
||||
if(dress_e(i_generator, p) /= 0d0) then
|
||||
fac = dress_e(i_generator, p)
|
||||
call omp_set_lock(lck_sto(p))
|
||||
do j=1,N_det
|
||||
do i=1,N_states
|
||||
cp(i,j,p,1) = cp(i,j,p,1) + breve_delta_m(i,j,1) * fac
|
||||
cp(i,j,p,2) = cp(i,j,p,2) + breve_delta_m(i,j,2) * fac
|
||||
enddo
|
||||
enddo
|
||||
call omp_unset_lock(lck_sto(p))
|
||||
end if
|
||||
end do
|
||||
|
||||
tmp = 0d0
|
||||
do i=N_det,1,-1
|
||||
tmp += psi_coef(i, dress_stoch_istate)*breve_delta_m(dress_stoch_istate, i, 1)
|
||||
end do
|
||||
!$OMP ATOMIC
|
||||
edI(i_generator) += tmp
|
||||
!$OMP ATOMIC
|
||||
f(i_generator) += 1
|
||||
!push bidon
|
||||
if(ntask_buf == size(task_buf)) then
|
||||
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, task_buf, ntask_buf)
|
||||
ntask_buf = 0
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
|
||||
!$OMP BARRIER
|
||||
if(ntask_buf /= 0) then
|
||||
call push_dress_results(zmq_socket_push, 0, 0, edI_task, edI_index, breve_delta_m, task_buf, ntask_buf)
|
||||
ntask_buf = 0
|
||||
end if
|
||||
!$OMP SINGLE
|
||||
if(purge_task_id /= 0) then
|
||||
do while(int(ending(1)) == dress_N_cp+1)
|
||||
call sleep(1)
|
||||
i= zmq_get_dvector(zmq_to_qp_run_socket, worker_id, "ending", ending, 1)
|
||||
end do
|
||||
|
||||
will_send = int(ending(1))
|
||||
breve_delta_m = 0d0
|
||||
|
||||
do l=will_send, 1,-1
|
||||
breve_delta_m(:,:,1) += cp(:,:,l,1)
|
||||
breve_delta_m(:,:,2) += cp(:,:,l,2)
|
||||
end do
|
||||
|
||||
breve_delta_m(:,:,:) = breve_delta_m(:,:,:) / dress_M_m(will_send)
|
||||
|
||||
do t=dress_dot_t(will_send)-1,0,-1
|
||||
breve_delta_m(:,:,1) = breve_delta_m(:,:,1) + delta_det(:,:,t,1)
|
||||
breve_delta_m(:,:,2) = breve_delta_m(:,:,2) + delta_det(:,:,t,2)
|
||||
end do
|
||||
|
||||
sum_f = 0
|
||||
do i=1,N_det_generators
|
||||
if(dress_P(i) <= will_send) sum_f = sum_f + f(i)
|
||||
end do
|
||||
call push_dress_results(zmq_socket_push, -will_send, sum_f, edI_task, edI_index, breve_delta_m, purge_task_id, 1)
|
||||
end if
|
||||
|
||||
!$OMP END SINGLE
|
||||
call disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id)
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
call end_zmq_push_socket(zmq_socket_push,thread)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do i=0,N_cp+1
|
||||
do i=0,dress_N_cp+1
|
||||
call omp_destroy_lock(lck_sto(i))
|
||||
end do
|
||||
do i=0,comb_teeth+1
|
||||
do i=0,pt2_N_teeth+1
|
||||
call omp_destroy_lock(lck_det(i))
|
||||
end do
|
||||
end subroutine
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine push_dress_results(zmq_socket_push, ind, cur_cp, delta_loc, int_buf, double_buf, det_buf, N_bufi, task_id)
|
||||
subroutine push_dress_results(zmq_socket_push, m_task, f, edI_task, edI_index, breve_delta_m, task_id, n_tasks)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
|
||||
integer, parameter :: sendt = 4
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
|
||||
double precision, intent(inout) :: delta_loc(N_states, N_det, 2)
|
||||
real(kind=4), allocatable :: delta_loc4(:,:,:)
|
||||
double precision, intent(in) :: double_buf(*)
|
||||
integer, intent(in) :: int_buf(*)
|
||||
integer(bit_kind), intent(in) :: det_buf(N_int, 2, *)
|
||||
integer, intent(in) :: N_bufi(3)
|
||||
integer :: N_buf(3)
|
||||
integer, intent(in) :: ind, cur_cp, task_id
|
||||
integer :: rc, i, j, k, l
|
||||
double precision :: contrib(N_states)
|
||||
real(sendt), allocatable :: r4buf(:,:,:)
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, ind, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop "push"
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, cur_cp, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop "push"
|
||||
|
||||
|
||||
if(cur_cp /= -1) then
|
||||
allocate(r4buf(N_states, N_det, 2))
|
||||
do i=1,2
|
||||
do j=1,N_det
|
||||
do k=1,N_states
|
||||
r4buf(k,j,i) = real(delta_loc(k,j,i), sendt)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,1), sendt*N_states*N_det, ZMQ_SNDMORE)
|
||||
if(rc /= sendt*N_states*N_det) stop "push"
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, r4buf(1,1,2), sendt*N_states*N_det, ZMQ_SNDMORE)
|
||||
if(rc /= sendt*N_states*N_det) stop "push"
|
||||
else
|
||||
contrib = 0d0
|
||||
do i=1,N_det
|
||||
contrib(:) += delta_loc(:,i, 1) * psi_coef(i, :)
|
||||
end do
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, contrib, 8*N_states, ZMQ_SNDMORE)
|
||||
if(rc /= 8*N_states) stop "push"
|
||||
integer, intent(in) :: m_task, f, edI_index(n_tasks)
|
||||
double precision, intent(in) :: breve_delta_m(N_states, N_det, 2), edI_task(n_tasks)
|
||||
integer, intent(in) :: task_id(pt2_n_tasks_max), n_tasks
|
||||
integer :: rc, i, j, k
|
||||
rc = f77_zmq_send( zmq_socket_push, m_task, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop "push3"
|
||||
|
||||
N_buf = N_bufi
|
||||
!N_buf = (/0,1,0/)
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, N_buf, 4*3, ZMQ_SNDMORE)
|
||||
if(rc /= 4*3) stop "push5"
|
||||
|
||||
if(N_buf(1) > N_dress_int_buffer) stop "run_dress_slave N_buf bad size?"
|
||||
if(N_buf(2) > N_dress_double_buffer) stop "run_dress_slave N_buf bad size?"
|
||||
if(N_buf(3) > N_dress_det_buffer) stop "run_dress_slave N_buf bad size?"
|
||||
|
||||
|
||||
if(N_buf(1) > 0) then
|
||||
rc = f77_zmq_send( zmq_socket_push, int_buf, 4*N_buf(1), ZMQ_SNDMORE)
|
||||
if(rc /= 4*N_buf(1)) stop "push6"
|
||||
end if
|
||||
|
||||
if(N_buf(2) > 0) then
|
||||
rc = f77_zmq_send( zmq_socket_push, double_buf, 8*N_buf(2), ZMQ_SNDMORE)
|
||||
if(rc /= 8*N_buf(2)) stop "push8"
|
||||
end if
|
||||
|
||||
if(N_buf(3) > 0) then
|
||||
rc = f77_zmq_send( zmq_socket_push, det_buf, 2*N_int*bit_kind*N_buf(3), ZMQ_SNDMORE)
|
||||
if(rc /= 2*N_int*bit_kind*N_buf(3)) stop "push10"
|
||||
end if
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
|
||||
if(rc /= 4) stop "push11"
|
||||
end if
|
||||
|
||||
! Activate is zmq_socket_push is a REQ
|
||||
if(m_task > 0) then
|
||||
rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop "push1"
|
||||
rc = f77_zmq_send( zmq_socket_push, f, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop "push4"
|
||||
rc = f77_zmq_send( zmq_socket_push, edI_task, 8*n_tasks, ZMQ_SNDMORE)
|
||||
if(rc /= 8*n_tasks) stop "push5"
|
||||
rc = f77_zmq_send( zmq_socket_push, edI_index, 4*n_tasks, 0)
|
||||
if(rc /= 4*n_tasks) stop "push6"
|
||||
else if(m_task == 0) then
|
||||
rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop "push1"
|
||||
rc = f77_zmq_send( zmq_socket_push, task_id, 4*n_tasks, 0)
|
||||
if(rc /= 4*n_tasks) stop "push2"
|
||||
else
|
||||
rc = f77_zmq_send( zmq_socket_push, f, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop "push4"
|
||||
rc = f77_zmq_send( zmq_socket_push, breve_delta_m, 8*N_det*N_states*2, ZMQ_SNDMORE)
|
||||
if(rc /= 8*N_det*N_states*2) stop "push6"
|
||||
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
|
||||
if(rc /= 4) stop "push6"
|
||||
end if
|
||||
! Activate is zmq_socket_pull is a REP
|
||||
IRP_IF ZMQ_PUSH
|
||||
IRP_ELSE
|
||||
character*(2) :: ok
|
||||
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
|
||||
IRP_ENDIF
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ real(4), real4buf, (N_states, N_det, 2) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine pull_dress_results(zmq_socket_pull, ind, cur_cp, delta_loc, int_buf, double_buf, det_buf, N_buf, task_id, contrib)
|
||||
subroutine pull_dress_results(zmq_socket_pull, m_task, f, edI_task, edI_index, breve_delta_m, task_id, n_tasks)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
integer, parameter :: sendt = 4
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
|
||||
integer, intent(out) :: cur_cp
|
||||
double precision, intent(inout) :: delta_loc(N_states, N_det, 2)
|
||||
double precision, intent(out) :: double_buf(*), contrib(N_states)
|
||||
integer, intent(out) :: int_buf(*)
|
||||
integer(bit_kind), intent(out) :: det_buf(N_int, 2, *)
|
||||
integer, intent(out) :: ind
|
||||
integer, intent(out) :: task_id
|
||||
integer, intent(out) :: m_task, f, edI_index(N_det_generators)
|
||||
double precision, intent(out) :: breve_delta_m(N_states, N_det, 2), edI_task(N_det_generators)
|
||||
integer, intent(out) :: task_id(pt2_n_tasks_max), n_tasks
|
||||
integer :: rc, i, j, k
|
||||
integer, intent(out) :: N_buf(3)
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, ind, 4, 0)
|
||||
if(rc /= 4) stop "pulla"
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, cur_cp, 4, 0)
|
||||
if(rc /= 4) stop "pulla"
|
||||
|
||||
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, m_task, 4, 0)
|
||||
if(rc /= 4) stop "pullc"
|
||||
|
||||
if(cur_cp /= -1) then
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,1), N_states*sendt*N_det, 0)
|
||||
if(rc /= sendt*N_states*N_det) stop "pullc"
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, real4buf(1,1,2), N_states*sendt*N_det, 0)
|
||||
if(rc /= sendt*N_states*N_det) stop "pulld"
|
||||
|
||||
do i=1,2
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(j,k)
|
||||
do j=1,N_det
|
||||
do k=1,N_states
|
||||
delta_loc(k,j,i) = real(real4buf(k,j,i), 8)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
else
|
||||
rc = f77_zmq_recv( zmq_socket_pull, contrib, 8*N_states, 0)
|
||||
if(rc /= 8*N_states) stop "pullc"
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, N_buf, 4*3, 0)
|
||||
if(rc /= 4*3) stop "pull"
|
||||
if(N_buf(1) > N_dress_int_buffer) stop "run_dress_slave N_buf bad size?"
|
||||
if(N_buf(2) > N_dress_double_buffer) stop "run_dress_slave N_buf bad size?"
|
||||
if(N_buf(3) > N_dress_det_buffer) stop "run_dress_slave N_buf bad size?"
|
||||
|
||||
|
||||
if(N_buf(1) > 0) then
|
||||
rc = f77_zmq_recv( zmq_socket_pull, int_buf, 4*N_buf(1), 0)
|
||||
if(rc /= 4*N_buf(1)) stop "pull1"
|
||||
if(m_task > 0) then
|
||||
rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
|
||||
if(rc /= 4) stop "pullc"
|
||||
rc = f77_zmq_recv( zmq_socket_pull, f, 4, 0)
|
||||
if(rc /= 4) stop "pullc"
|
||||
rc = f77_zmq_recv( zmq_socket_pull, edI_task, 8*n_tasks, 0)
|
||||
if(rc /= 8*n_tasks) stop "pullc"
|
||||
rc = f77_zmq_recv( zmq_socket_pull, edI_index, 4*n_tasks, 0)
|
||||
if(rc /= 4*n_tasks) stop "pullc"
|
||||
else if(m_task==0) then
|
||||
rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
|
||||
if(rc /= 4) stop "pullc"
|
||||
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4*n_tasks, 0)
|
||||
if(rc /= 4*n_tasks) stop "pull4"
|
||||
else
|
||||
rc = f77_zmq_recv( zmq_socket_pull, f, 4, 0)
|
||||
if(rc /= 4) stop "pullc"
|
||||
rc = f77_zmq_recv( zmq_socket_pull, breve_delta_m, 8*N_det*N_states*2, 0)
|
||||
if(rc /= 8*N_det*N_states*2) stop "pullc"
|
||||
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
|
||||
if(rc /= 4) stop "pull4"
|
||||
end if
|
||||
|
||||
if(N_buf(2) > 0) then
|
||||
rc = f77_zmq_recv( zmq_socket_pull, double_buf, 8*N_buf(2), 0)
|
||||
if(rc /= 8*N_buf(2)) stop "pull2"
|
||||
end if
|
||||
|
||||
if(N_buf(3) > 0) then
|
||||
rc = f77_zmq_recv( zmq_socket_pull, det_buf, 2*N_int*bit_kind*N_buf(3), 0)
|
||||
if(rc /= 2*N_int*bit_kind*N_buf(3)) stop "pull3"
|
||||
end if
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
|
||||
if(rc /= 4) stop "pull4"
|
||||
end if
|
||||
! Activate is zmq_socket_pull is a REP
|
||||
IRP_IF ZMQ_PUSH
|
||||
IRP_ELSE
|
||||
|
|
|
|||
|
|
@ -26,3 +26,9 @@ doc: Type of zeroth-order Hamiltonian [ EN | Barycentric ]
|
|||
interface: ezfio,provider,ocaml
|
||||
default: EN
|
||||
|
||||
[dress_relative_error]
|
||||
type: Normalized_float
|
||||
doc: Stop stochastic dressing when the relative error is smaller than PT2_relative_error
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.001
|
||||
|
||||
|
|
|
|||
|
|
@ -1,159 +0,0 @@
|
|||
program shifted_bk
|
||||
implicit none
|
||||
integer :: i,j,k
|
||||
double precision, allocatable :: pt2(:)
|
||||
integer :: degree
|
||||
integer :: n_det_before
|
||||
double precision :: threshold_davidson_in
|
||||
|
||||
allocate (pt2(N_states))
|
||||
|
||||
double precision :: hf_energy_ref
|
||||
logical :: has
|
||||
double precision :: relative_error, absolute_error
|
||||
integer :: N_states_p
|
||||
character*(512) :: fmt
|
||||
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order
|
||||
|
||||
|
||||
pt2 = -huge(1.e0)
|
||||
threshold_davidson_in = threshold_davidson
|
||||
threshold_davidson = threshold_davidson_in * 100.d0
|
||||
SOFT_TOUCH threshold_davidson
|
||||
|
||||
call diagonalize_CI_dressed
|
||||
call save_wavefunction
|
||||
|
||||
call ezfio_has_hartree_fock_energy(has)
|
||||
if (has) then
|
||||
call ezfio_get_hartree_fock_energy(hf_energy_ref)
|
||||
else
|
||||
hf_energy_ref = ref_bitmask_energy
|
||||
endif
|
||||
|
||||
if (N_det > N_det_max) then
|
||||
psi_det = psi_det_sorted
|
||||
psi_coef = psi_coef_sorted
|
||||
N_det = N_det_max
|
||||
soft_touch N_det psi_det psi_coef
|
||||
call diagonalize_CI_dressed
|
||||
call save_wavefunction
|
||||
N_states_p = min(N_det,N_states)
|
||||
endif
|
||||
|
||||
n_det_before = 0
|
||||
|
||||
character*(8) :: pt2_string
|
||||
double precision :: threshold_selectors_save, threshold_generators_save
|
||||
threshold_selectors_save = threshold_selectors
|
||||
threshold_generators_save = threshold_generators
|
||||
double precision :: error(N_states), energy(N_states)
|
||||
error = 0.d0
|
||||
|
||||
threshold_selectors = 1.d0
|
||||
threshold_generators = 1d0
|
||||
|
||||
if (.True.) then
|
||||
pt2_string = '(sh-Bk) '
|
||||
do while ( (N_det < N_det_max) )
|
||||
write(*,'(A)') '--------------------------------------------------------------------------------'
|
||||
|
||||
N_det_delta_ij = N_det
|
||||
|
||||
do i=1,N_states
|
||||
energy(i) = psi_energy(i)+nuclear_repulsion
|
||||
enddo
|
||||
|
||||
PROVIDE delta_ij_tmp
|
||||
call delta_ij_done()
|
||||
|
||||
call diagonalize_ci_dressed
|
||||
do i=1,N_states
|
||||
pt2(i) = ci_energy_dressed(i) - energy(i)
|
||||
enddo
|
||||
|
||||
N_states_p = min(N_det,N_states)
|
||||
|
||||
print *, ''
|
||||
print '(A,I12)', 'Summary at N_det = ', N_det
|
||||
print '(A)', '-----------------------------------'
|
||||
print *, ''
|
||||
print *, ''
|
||||
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
write(fmt,*) '(12X,', N_states_p, '(6X,A7,1X,I6,10X))'
|
||||
write(*,fmt) ('State',k, k=1,N_states_p)
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
write(fmt,*) '(A12,', N_states_p, '(1X,F14.8,15X))'
|
||||
write(*,fmt) '# E ', energy(1:N_states_p)
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', energy(1:N_states_p)-energy(1)
|
||||
write(*,fmt) '# Excit. (eV)', (energy(1:N_states_p)-energy(1))*27.211396641308d0
|
||||
endif
|
||||
write(fmt,*) '(A12,', 2*N_states_p, '(1X,F14.8))'
|
||||
write(*,fmt) '# PT2'//pt2_string, (pt2(k), error(k), k=1,N_states_p)
|
||||
write(*,'(A)') '#'
|
||||
write(*,fmt) '# E+PT2 ', (energy(k)+pt2(k),error(k), k=1,N_states_p)
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', ( (energy(k)+pt2(k)-energy(1)-pt2(1)), &
|
||||
dsqrt(error(k)*error(k)+error(1)*error(1)), k=1,N_states_p)
|
||||
write(*,fmt) '# Excit. (eV)', ( (energy(k)+pt2(k)-energy(1)-pt2(1))*27.211396641308d0, &
|
||||
dsqrt(error(k)*error(k)+error(1)*error(1))*27.211396641308d0, k=1,N_states_p)
|
||||
endif
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
print *, ''
|
||||
|
||||
print *, 'N_det = ', N_det
|
||||
print *, 'N_states = ', N_states
|
||||
|
||||
do k=1, N_states_p
|
||||
print*,'State ',k
|
||||
print *, 'PT2 = ', pt2(k)
|
||||
print *, 'E = ', energy(k)
|
||||
print *, 'E+PT2'//pt2_string//' = ', energy(k)+pt2(k)
|
||||
enddo
|
||||
|
||||
print *, '-----'
|
||||
if(N_states.gt.1)then
|
||||
print *, 'Variational Energy difference (au | eV)'
|
||||
do i=2, N_states_p
|
||||
print*,'Delta E = ', (energy(i) - energy(1)), &
|
||||
(energy(i) - energy(1)) * 27.211396641308d0
|
||||
enddo
|
||||
print *, '-----'
|
||||
print*, 'Variational + perturbative Energy difference (au | eV)'
|
||||
do i=2, N_states_p
|
||||
print*,'Delta E = ', (energy(i)+ pt2(i) - (energy(1) + pt2(1))), &
|
||||
(energy(i)+ pt2(i) - (energy(1) + pt2(1))) * 27.211396641308d0
|
||||
enddo
|
||||
endif
|
||||
call ezfio_set_shiftedbk_energy_pt2(energy(1)+pt2(1))
|
||||
! call dump_fci_iterations_value(N_det,energy,pt2)
|
||||
|
||||
n_det_before = N_det
|
||||
|
||||
PROVIDE psi_coef
|
||||
PROVIDE psi_det
|
||||
PROVIDE psi_det_sorted
|
||||
|
||||
if (N_det >= N_det_max) then
|
||||
threshold_davidson = threshold_davidson_in
|
||||
end if
|
||||
call save_wavefunction
|
||||
call ezfio_set_shiftedbk_energy(energy(1))
|
||||
call ezfio_set_shiftedbk_energy_pt2(ci_energy_dressed(1))
|
||||
enddo
|
||||
endif
|
||||
|
||||
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
|
@ -298,9 +298,8 @@ subroutine dress_with_alpha_buffer(Nstates,Ndet,Nint,delta_ij_loc, i_gen, minili
|
|||
|
||||
|
||||
haa = diag_H_mat_elem_fock(psi_det_generators(1,1,i_gen),alpha,fock_diag_tmp_(1,1,iproc),N_int)
|
||||
|
||||
|
||||
call dress_with_alpha_(Nstates, Ndet, Nint, delta_ij_loc, minilist, det_minilist, n_minilist, alpha, haa, contrib, c_alpha, iproc)
|
||||
|
||||
slave_sum_alpha2(:,iproc) += c_alpha(:)**2
|
||||
if(contrib < sb(iproc)%mini) then
|
||||
call add_to_selection_buffer(sb(iproc), alpha, contrib)
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ default: 1.e-12
|
|||
type: States_number
|
||||
doc: Number of states to consider during the Davdison diagonalization
|
||||
default: 4
|
||||
interface: ezfio,provider,ocaml
|
||||
interface: ezfio,ocaml
|
||||
|
||||
[davidson_sze_max]
|
||||
type: Strictly_positive_int
|
||||
|
|
|
|||
35
src/Davidson/ezfio.irp.f
Normal file
35
src/Davidson/ezfio.irp.f
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
BEGIN_PROVIDER [ integer, n_states_diag ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of states to consider during the Davdison diagonalization
|
||||
END_DOC
|
||||
|
||||
logical :: has
|
||||
PROVIDE ezfio_filename
|
||||
if (mpi_master) then
|
||||
|
||||
call ezfio_has_davidson_n_states_diag(has)
|
||||
if (has) then
|
||||
call ezfio_get_davidson_n_states_diag(n_states_diag)
|
||||
else
|
||||
print *, 'davidson/n_states_diag not found in EZFIO file'
|
||||
stop 1
|
||||
endif
|
||||
n_states_diag = max(N_states, N_states_diag)
|
||||
endif
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( n_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read n_states_diag with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
call write_time(6)
|
||||
if (mpi_master) then
|
||||
write(6, *) 'Read n_states_diag'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
|
@ -28,6 +28,7 @@ subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze)
|
|||
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||
allocate(u_t(N_st,N_det),v_t(N_st,N_det),s_t(N_st,N_det))
|
||||
|
||||
do k=1,N_st
|
||||
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
|
|
|
|||
|
|
@ -167,8 +167,7 @@ subroutine decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
|||
end select
|
||||
end
|
||||
|
||||
|
||||
subroutine get_double_excitation(det1,det2,exc,phase,Nint)
|
||||
subroutine get_double_excitation_ref(det1,det2,exc,phase,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
|
@ -312,6 +311,137 @@ subroutine get_double_excitation(det1,det2,exc,phase,Nint)
|
|||
|
||||
end
|
||||
|
||||
subroutine get_phasemask_bit(det1, pm, Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: det1(Nint,2)
|
||||
integer(bit_kind), intent(out) :: pm(Nint,2)
|
||||
integer(bit_kind) :: tmp
|
||||
integer :: ispin, i
|
||||
do ispin=1,2
|
||||
tmp = 0_8
|
||||
do i=1,Nint
|
||||
pm(i,ispin) = xor(det1(i,ispin), ishft(det1(i,ispin), 1))
|
||||
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 2))
|
||||
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 4))
|
||||
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 8))
|
||||
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 16))
|
||||
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 32))
|
||||
pm(i,ispin) = xor(pm(i,ispin), tmp)
|
||||
if(iand(popcnt(det1(i,ispin)), 1) == 1) tmp = not(tmp)
|
||||
end do
|
||||
end do
|
||||
end subroutine
|
||||
|
||||
|
||||
subroutine get_double_excitation(det1,det2,exc,phase,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns the two excitation operators between two doubly excited determinants and the phase
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: det1(Nint,2)
|
||||
integer(bit_kind), intent(in) :: det2(Nint,2)
|
||||
integer, intent(out) :: exc(0:2,2,2)
|
||||
double precision, intent(out) :: phase
|
||||
integer :: tz
|
||||
integer :: l, ispin, idx_hole, idx_particle, ishift
|
||||
integer :: nperm
|
||||
integer :: i,j,k,m,n
|
||||
integer :: high, low
|
||||
integer :: a,b,c,d
|
||||
integer(bit_kind) :: hole, particle, tmp, pm(Nint,2)
|
||||
double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /)
|
||||
double precision :: refaz
|
||||
logical :: ok
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
!do ispin=1,2
|
||||
!tmp = 0_8
|
||||
!do i=1,Nint
|
||||
! pm(i,ispin) = xor(det1(i,ispin), ishft(det1(i,ispin), 1))
|
||||
! pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 2))
|
||||
! pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 4))
|
||||
! pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 8))
|
||||
! pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 16))
|
||||
! pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 32))
|
||||
! pm(i,ispin) = xor(pm(i,ispin), tmp)
|
||||
! if(iand(popcnt(det1(i,ispin)), 1) == 1) tmp = not(tmp)
|
||||
!end do
|
||||
!end do
|
||||
call get_phasemask_bit(det1, pm, Nint)
|
||||
nperm = 0
|
||||
exc(0,1,1) = 0
|
||||
exc(0,2,1) = 0
|
||||
exc(0,1,2) = 0
|
||||
exc(0,2,2) = 0
|
||||
do ispin = 1,2
|
||||
idx_particle = 0
|
||||
idx_hole = 0
|
||||
ishift = 1-bit_kind_size
|
||||
!par = 0
|
||||
do l=1,Nint
|
||||
ishift = ishift + bit_kind_size
|
||||
if (det1(l,ispin) == det2(l,ispin)) then
|
||||
cycle
|
||||
endif
|
||||
tmp = xor( det1(l,ispin), det2(l,ispin) )
|
||||
particle = iand(tmp, det2(l,ispin))
|
||||
hole = iand(tmp, det1(l,ispin))
|
||||
do while (particle /= 0_bit_kind)
|
||||
tz = trailz(particle)
|
||||
nperm = nperm + iand(ishft(pm(l,ispin), -tz), 1)
|
||||
idx_particle = idx_particle + 1
|
||||
exc(0,2,ispin) = exc(0,2,ispin) + 1
|
||||
exc(idx_particle,2,ispin) = tz+ishift
|
||||
particle = iand(particle,particle-1_bit_kind)
|
||||
enddo
|
||||
if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin)==2
|
||||
exit
|
||||
endif
|
||||
do while (hole /= 0_bit_kind)
|
||||
tz = trailz(hole)
|
||||
nperm = nperm + iand(ishft(pm(l,ispin), -tz), 1)
|
||||
idx_hole = idx_hole + 1
|
||||
exc(0,1,ispin) = exc(0,1,ispin) + 1
|
||||
exc(idx_hole,1,ispin) = tz+ishift
|
||||
hole = iand(hole,hole-1_bit_kind)
|
||||
enddo
|
||||
if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin)
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
select case (exc(0,1,ispin))
|
||||
case(0)
|
||||
cycle
|
||||
|
||||
case(1)
|
||||
if(exc(1,1,ispin) < exc(1,2,ispin)) nperm = nperm+1
|
||||
|
||||
case (2)
|
||||
a = exc(1,1,ispin)
|
||||
b = exc(1,2,ispin)
|
||||
c = exc(2,1,ispin)
|
||||
d = exc(2,2,ispin)
|
||||
|
||||
if(min(a,c) > max(b,d) .or. min(b,d) > max(a,c) .or. (a-b)*(c-d)<0) then
|
||||
nperm = nperm + 1
|
||||
end if
|
||||
exit
|
||||
end select
|
||||
|
||||
enddo
|
||||
phase = phase_dble(iand(nperm,1))
|
||||
!call get_double_excitation_ref(det1,det2,exc,refaz,Nint)
|
||||
!if(phase == refaz) then
|
||||
! print *, "phase", phase, refaz, n, exc(0,1,1)
|
||||
!end if
|
||||
end
|
||||
|
||||
subroutine get_mono_excitation(det1,det2,exc,phase,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user