mirror of
https://gitlab.com/scemama/qp_plugins_scemama.git
synced 2024-12-22 12:23:37 +01:00
Merge branch 'master' of https://gitlab.com/scemama/qp_plugins_scemama
This commit is contained in:
Emmanuel Giner
commit
d5192bcbc9
6
devel/fci_complete/EZFIO.cfg
Normal file
6
devel/fci_complete/EZFIO.cfg
Normal file
@ -0,0 +1,6 @@
|
||||
[energy]
|
||||
type: double precision
|
||||
doc: Calculated Selected |FCI| energy
|
||||
interface: ezfio
|
||||
size: (determinants.n_states)
|
||||
|
||||
3
devel/fci_complete/NEED
Normal file
3
devel/fci_complete/NEED
Normal file
@ -0,0 +1,3 @@
|
||||
davidson_undressed
|
||||
hartree_fock
|
||||
determinants
|
||||
4
devel/fci_complete/README.rst
Normal file
4
devel/fci_complete/README.rst
Normal file
@ -0,0 +1,4 @@
|
||||
===
|
||||
mpn
|
||||
===
|
||||
|
||||
8
devel/fci_complete/fci_complete.irp.f
Normal file
8
devel/fci_complete/fci_complete.irp.f
Normal file
@ -0,0 +1,8 @@
|
||||
program fci_complete
|
||||
|
||||
call generate_fci_space
|
||||
call diagonalize_ci
|
||||
|
||||
end
|
||||
|
||||
|
||||
75
devel/fci_complete/generate_fci.irp.f
Normal file
75
devel/fci_complete/generate_fci.irp.f
Normal file
@ -0,0 +1,75 @@
|
||||
subroutine generate_fci_space
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Generates the complete FCI space
|
||||
END_DOC
|
||||
integer :: i, sze, ncore
|
||||
integer(bit_kind) :: o(N_int,2)
|
||||
integer(bit_kind) :: u, coremask
|
||||
|
||||
if (mo_num > 64) then
|
||||
stop 'No more than 64 MOs'
|
||||
endif
|
||||
|
||||
ncore = 0
|
||||
coremask = 0_bit_kind
|
||||
do i=1,mo_num
|
||||
if (trim(mo_class(i)) == 'Core') then
|
||||
ncore += 1
|
||||
coremask = ibset(coremask,i-1)
|
||||
endif
|
||||
enddo
|
||||
o(1,1) = iand(full_ijkl_bitmask(1),not(coremask))
|
||||
o(1,2) = 0_bit_kind
|
||||
|
||||
call configuration_to_dets_size(o,n_det_alpha_unique,elec_alpha_num-ncore,N_int)
|
||||
TOUCH n_det_alpha_unique
|
||||
|
||||
integer :: k,n,m, t, t1, t2
|
||||
k=0
|
||||
n = elec_alpha_num
|
||||
m = mo_num - n
|
||||
n = n
|
||||
|
||||
u = shiftl(1_bit_kind,n) -1
|
||||
do while (u < shiftl(1_bit_kind,n+m))
|
||||
if (iand(coremask, u) == coremask) then
|
||||
k = k+1
|
||||
psi_det_alpha_unique(1,k) = u
|
||||
endif
|
||||
t = ior(u,u-1)
|
||||
t1 = t+1
|
||||
IRP_IF WITHOUT_TRAILZ
|
||||
t2 = shiftr((iand(not(t),t1)-1), popcnt(ieor(u,u-1)))
|
||||
IRP_ELSE
|
||||
t2 = shiftr((iand(not(t),t1)-1), trailz(u)+1)
|
||||
IRP_ENDIF
|
||||
u = ior(t1,t2)
|
||||
enddo
|
||||
|
||||
|
||||
call configuration_to_dets_size(o,n_det_beta_unique,elec_beta_num-ncore,N_int)
|
||||
TOUCH n_det_beta_unique
|
||||
|
||||
k=0
|
||||
n = elec_beta_num
|
||||
m = mo_num - n
|
||||
u = shiftl(1_bit_kind,n) -1
|
||||
do while (u < shiftl(1_bit_kind,n+m))
|
||||
if (iand(coremask, u) == coremask) then
|
||||
k = k+1
|
||||
psi_det_beta_unique(1,k) = u
|
||||
endif
|
||||
t = ior(u,u-1)
|
||||
t1 = t+1
|
||||
t2 = shiftr((iand(not(t),t1)-1), trailz(u)+1)
|
||||
u = ior(t1,t2)
|
||||
enddo
|
||||
|
||||
call generate_all_alpha_beta_det_products
|
||||
|
||||
print *, 'Ndet = ', N_det
|
||||
|
||||
end
|
||||
|
||||
@ -77,6 +77,7 @@ subroutine run
|
||||
do k=1,ao_num
|
||||
do j=l,ao_num
|
||||
do i=k,ao_num
|
||||
if (i==j .and. k<l) cycle
|
||||
if (i>=j) then
|
||||
integral = get_ao_two_e_integral(i,j,k,l,ao_integrals_map)
|
||||
if (integral /= 0.d0) then
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
program export_integrals_mo
|
||||
PROVIDE mo_two_e_integrals_in_map
|
||||
call run
|
||||
end
|
||||
|
||||
@ -53,7 +54,8 @@ subroutine run
|
||||
integer :: n_integrals
|
||||
integer(key_kind) :: idx
|
||||
|
||||
double precision, external :: get_two_e_integral
|
||||
double precision, external :: mo_two_e_integral
|
||||
|
||||
|
||||
allocate (A(mo_num,mo_num))
|
||||
call ezfio_set_nuclei_nuclear_repulsion(nuclear_repulsion)
|
||||
@ -61,13 +63,15 @@ subroutine run
|
||||
call write_2d('T_mo.qp',mo_kinetic_integrals)
|
||||
call write_2d('P_mo.qp',mo_pseudo_integrals)
|
||||
call write_2d('V_mo.qp',mo_integrals_n_e)
|
||||
call write_2d('H_mo.qp',mo_one_e_integrals)
|
||||
|
||||
iunit = getunitandopen('W_mo.qp','w')
|
||||
do l=1,mo_num
|
||||
do k=1,mo_num
|
||||
do j=1,mo_num
|
||||
do i=1,mo_num
|
||||
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
|
||||
do j=l,mo_num
|
||||
do i=k,mo_num
|
||||
if (i==j .and. k<l) cycle
|
||||
integral = mo_two_e_integral(i,j,k,l)
|
||||
if (integral /= 0.d0) then
|
||||
write (iunit,'(4(I5,2X),E22.15)') i,j,k,l, integral
|
||||
endif
|
||||
|
||||
@ -17,31 +17,36 @@ subroutine run
|
||||
!
|
||||
! E.qp : Contains the nuclear repulsion energy
|
||||
!
|
||||
! Tmo.qp : kinetic energy integrals
|
||||
! T_mo.qp : kinetic energy integrals
|
||||
!
|
||||
! Smo.qp : overlap matrix
|
||||
! P_mo.qp : pseudopotential integrals
|
||||
!
|
||||
! Pmo.qp : pseudopotential integrals
|
||||
! V_mo.qp : electron-nucleus potential
|
||||
!
|
||||
! Vmo.qp : electron-nucleus potential
|
||||
! H_mo.qp : core hamiltonian. If hmo exists, the other 1-e files are not read
|
||||
!
|
||||
! Wmo.qp : electron repulsion integrals
|
||||
! W_mo.qp : electron repulsion integrals
|
||||
!
|
||||
END_DOC
|
||||
|
||||
integer :: iunit
|
||||
integer :: getunitandopen
|
||||
integer :: iunit
|
||||
integer :: getunitandopen
|
||||
|
||||
integer ::i,j,k,l
|
||||
double precision :: integral
|
||||
double precision, allocatable :: A(:,:)
|
||||
integer :: i,j,k,l
|
||||
double precision :: integral
|
||||
double precision, allocatable :: A(:,:)
|
||||
|
||||
integer :: n_integrals
|
||||
integer(key_kind), allocatable :: buffer_i(:)
|
||||
integer :: n_integrals
|
||||
logical :: exists
|
||||
integer(key_kind), allocatable :: buffer_i(:)
|
||||
real(integral_kind), allocatable :: buffer_values(:)
|
||||
|
||||
allocate(buffer_i(mo_num**3), buffer_values(mo_num**3))
|
||||
allocate (A(mo_num,mo_num))
|
||||
PROVIDE mo_integrals_map
|
||||
PROVIDE mo_integrals_threshold
|
||||
|
||||
! Nuclear repulsion
|
||||
|
||||
A(1,1) = huge(1.d0)
|
||||
iunit = getunitandopen('E.qp','r')
|
||||
@ -53,70 +58,109 @@ subroutine run
|
||||
call ezfio_set_nuclei_io_nuclear_repulsion('Read')
|
||||
endif
|
||||
|
||||
A = 0.d0
|
||||
i = 1
|
||||
j = 1
|
||||
iunit = getunitandopen('Tmo.qp','r')
|
||||
do
|
||||
read (iunit,*,end=10) i,j, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in Tmo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in Tmo.qp'
|
||||
endif
|
||||
A(i,j) = integral
|
||||
enddo
|
||||
10 continue
|
||||
close(iunit)
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_kinetic(A)
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_kinetic('Read')
|
||||
! One-electron integrals
|
||||
|
||||
A = 0.d0
|
||||
i = 1
|
||||
j = 1
|
||||
iunit = getunitandopen('Pmo.qp','r')
|
||||
do
|
||||
read (iunit,*,end=14) i,j, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in Pmo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in Pmo.qp'
|
||||
endif
|
||||
A(i,j) = integral
|
||||
enddo
|
||||
14 continue
|
||||
close(iunit)
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_pseudo(A)
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_pseudo('Read')
|
||||
exists = .False.
|
||||
inquire(file='H_mo.qp',exist=exists)
|
||||
if (exists) then
|
||||
|
||||
A = 0.d0
|
||||
i = 1
|
||||
j = 1
|
||||
iunit = getunitandopen('Vmo.qp','r')
|
||||
do
|
||||
read (iunit,*,end=12) i,j, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in Vmo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in Vmo.qp'
|
||||
endif
|
||||
A(i,j) = integral
|
||||
enddo
|
||||
12 continue
|
||||
close(iunit)
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_n_e(A)
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_n_e('Read')
|
||||
A = 0.d0
|
||||
i = 1
|
||||
j = 1
|
||||
iunit = getunitandopen('H_mo.qp','r')
|
||||
do
|
||||
read (iunit,*,end=8) i,j, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in H_mo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in H_mo.qp'
|
||||
endif
|
||||
A(i,j) = integral
|
||||
enddo
|
||||
8 continue
|
||||
close(iunit)
|
||||
call ezfio_set_mo_one_e_ints_mo_one_e_integrals(A)
|
||||
call ezfio_set_mo_one_e_ints_io_mo_one_e_integrals('Read')
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_kinetic('None')
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_pseudo('None')
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_n_e('None')
|
||||
|
||||
iunit = getunitandopen('Wmo.qp','r')
|
||||
else
|
||||
|
||||
call ezfio_set_mo_one_e_ints_io_mo_one_e_integrals('None')
|
||||
|
||||
A = 0.d0
|
||||
i = 1
|
||||
j = 1
|
||||
iunit = getunitandopen('T_mo.qp','r')
|
||||
do
|
||||
read (iunit,*,end=10) i,j, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in T_mo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in T_mo.qp'
|
||||
endif
|
||||
A(i,j) = integral
|
||||
enddo
|
||||
10 continue
|
||||
close(iunit)
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_kinetic(A)
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_kinetic('Read')
|
||||
|
||||
A = 0.d0
|
||||
i = 1
|
||||
j = 1
|
||||
iunit = getunitandopen('P_mo.qp','r')
|
||||
do
|
||||
read (iunit,*,end=14) i,j, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in P_mo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in P_mo.qp'
|
||||
endif
|
||||
A(i,j) = integral
|
||||
enddo
|
||||
14 continue
|
||||
close(iunit)
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_pseudo(A)
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_pseudo('Read')
|
||||
|
||||
A = 0.d0
|
||||
i = 1
|
||||
j = 1
|
||||
iunit = getunitandopen('V_mo.qp','r')
|
||||
do
|
||||
read (iunit,*,end=12) i,j, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in V_mo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in V_mo.qp'
|
||||
endif
|
||||
A(i,j) = integral
|
||||
enddo
|
||||
12 continue
|
||||
close(iunit)
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_n_e(A)
|
||||
call ezfio_set_mo_one_e_ints_io_mo_integrals_n_e('Read')
|
||||
|
||||
end if
|
||||
|
||||
|
||||
! Two-electron integrals
|
||||
|
||||
iunit = getunitandopen('W_mo.qp','r')
|
||||
n_integrals=0
|
||||
i = 1
|
||||
j = 1
|
||||
@ -127,26 +171,25 @@ subroutine run
|
||||
read (iunit,*,end=13) i,j,k,l, integral
|
||||
if (i<0 .or. i>mo_num) then
|
||||
print *, i
|
||||
stop 'i out of bounds in Wmo.qp'
|
||||
stop 'i out of bounds in W_mo.qp'
|
||||
endif
|
||||
if (j<0 .or. j>mo_num) then
|
||||
print *, j
|
||||
stop 'j out of bounds in Wmo.qp'
|
||||
stop 'j out of bounds in W_mo.qp'
|
||||
endif
|
||||
if (k<0 .or. k>mo_num) then
|
||||
print *, k
|
||||
stop 'k out of bounds in Wmo.qp'
|
||||
stop 'k out of bounds in W_mo.qp'
|
||||
endif
|
||||
if (l<0 .or. l>mo_num) then
|
||||
print *, l
|
||||
stop 'l out of bounds in Wmo.qp'
|
||||
stop 'l out of bounds in W_mo.qp'
|
||||
endif
|
||||
n_integrals += 1
|
||||
call mo_two_e_integrals_index(i, j, k, l, buffer_i(n_integrals) )
|
||||
buffer_values(n_integrals) = integral
|
||||
if (n_integrals == size(buffer_i)) then
|
||||
call insert_into_mo_integrals_map(n_integrals, buffer_i, buffer_values, &
|
||||
real(mo_integrals_threshold,integral_kind))
|
||||
call map_append(mo_integrals_map, buffer_i, buffer_values, n_integrals)
|
||||
n_integrals = 0
|
||||
endif
|
||||
enddo
|
||||
@ -154,13 +197,15 @@ subroutine run
|
||||
close(iunit)
|
||||
|
||||
if (n_integrals > 0) then
|
||||
call insert_into_mo_integrals_map(n_integrals, buffer_i, buffer_values, &
|
||||
real(mo_integrals_threshold,integral_kind))
|
||||
call map_append(mo_integrals_map, buffer_i, buffer_values, n_integrals)
|
||||
endif
|
||||
|
||||
call map_sort(mo_integrals_map)
|
||||
call map_unique(mo_integrals_map)
|
||||
|
||||
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map)
|
||||
call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals('Read')
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
59
devel/mpn/.gitignore
vendored
Normal file
59
devel/mpn/.gitignore
vendored
Normal file
@ -0,0 +1,59 @@
|
||||
IRPF90_temp/
|
||||
IRPF90_man/
|
||||
build.ninja
|
||||
irpf90.make
|
||||
ezfio_interface.irp.f
|
||||
irpf90_entities
|
||||
tags
|
||||
Makefile
|
||||
ao_basis
|
||||
ao_one_e_ints
|
||||
ao_two_e_erf_ints
|
||||
ao_two_e_ints
|
||||
aux_quantities
|
||||
becke_numerical_grid
|
||||
bitmask
|
||||
cis
|
||||
cisd
|
||||
cipsi
|
||||
davidson
|
||||
davidson_dressed
|
||||
davidson_undressed
|
||||
density_for_dft
|
||||
determinants
|
||||
dft_keywords
|
||||
dft_utils_in_r
|
||||
dft_utils_one_e
|
||||
dft_utils_two_body
|
||||
dressing
|
||||
dummy
|
||||
electrons
|
||||
ezfio_files
|
||||
fci
|
||||
generators_cas
|
||||
generators_full
|
||||
hartree_fock
|
||||
iterations
|
||||
kohn_sham
|
||||
kohn_sham_rs
|
||||
mo_basis
|
||||
mo_guess
|
||||
mo_one_e_ints
|
||||
mo_two_e_erf_ints
|
||||
mo_two_e_ints
|
||||
mpi
|
||||
mrpt_utils
|
||||
nuclei
|
||||
perturbation
|
||||
pseudo
|
||||
psiref_cas
|
||||
psiref_utils
|
||||
scf_utils
|
||||
selectors_cassd
|
||||
selectors_full
|
||||
selectors_utils
|
||||
single_ref_method
|
||||
slave
|
||||
tools
|
||||
utils
|
||||
zmq
|
||||
12
devel/mpn/EZFIO.cfg
Normal file
12
devel/mpn/EZFIO.cfg
Normal file
@ -0,0 +1,12 @@
|
||||
[energy]
|
||||
type: double precision
|
||||
doc: Calculated Selected |FCI| energy
|
||||
interface: ezfio
|
||||
size: (determinants.n_states)
|
||||
|
||||
[mp_order]
|
||||
type: integer
|
||||
doc: Max order of MPn
|
||||
interface: ezfio, provider, ocaml
|
||||
default: 4
|
||||
|
||||
3
devel/mpn/NEED
Normal file
3
devel/mpn/NEED
Normal file
@ -0,0 +1,3 @@
|
||||
davidson_undressed
|
||||
hartree_fock
|
||||
determinants
|
||||
4
devel/mpn/README.rst
Normal file
4
devel/mpn/README.rst
Normal file
@ -0,0 +1,4 @@
|
||||
===
|
||||
mpn
|
||||
===
|
||||
|
||||
23
devel/mpn/energies.irp.f
Normal file
23
devel/mpn/energies.irp.f
Normal file
@ -0,0 +1,23 @@
|
||||
BEGIN_PROVIDER [ double precision, energy_det_i, (N_det) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Fock Energy of determinant |I> (sum of epsilon_i)
|
||||
END_DOC
|
||||
integer :: i, k, n
|
||||
integer :: list(elec_alpha_num)
|
||||
|
||||
do k=1,N_det
|
||||
call bitstring_to_list(psi_det(1,1,k), list, n, N_int)
|
||||
energy_det_i(k) = 0.d0
|
||||
do i=1,n
|
||||
energy_det_i(k) += fock_matrix_diag_mo(list(i))
|
||||
enddo
|
||||
call bitstring_to_list(psi_det(1,2,k), list, n, N_int)
|
||||
do i=1,n
|
||||
energy_det_i(k) += fock_matrix_diag_mo(list(i))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
80
devel/mpn/generate_fci.irp.f
Normal file
80
devel/mpn/generate_fci.irp.f
Normal file
@ -0,0 +1,80 @@
|
||||
subroutine generate_fci_space
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Generates the complete FCI space
|
||||
END_DOC
|
||||
integer :: i, sze, ncore
|
||||
integer(bit_kind) :: o(N_int,2)
|
||||
integer(bit_kind) :: u, coremask
|
||||
|
||||
if (mo_num > 64) then
|
||||
stop 'No more than 64 MOs'
|
||||
endif
|
||||
|
||||
ncore = 0
|
||||
coremask = 0_bit_kind
|
||||
do i=1,mo_num
|
||||
if (trim(mo_class(i)) == 'Core') then
|
||||
ncore += 1
|
||||
coremask = ibset(coremask,i-1)
|
||||
endif
|
||||
enddo
|
||||
o(1,1) = iand(full_ijkl_bitmask(1),not(coremask))
|
||||
o(1,2) = 0_bit_kind
|
||||
|
||||
call configuration_to_dets_size(o,n_det_alpha_unique,elec_alpha_num-ncore,N_int)
|
||||
TOUCH n_det_alpha_unique
|
||||
|
||||
integer :: k,n,m, t, t1, t2
|
||||
k=0
|
||||
n = elec_alpha_num
|
||||
m = mo_num - n
|
||||
n = n
|
||||
|
||||
u = shiftl(1_bit_kind,n) -1
|
||||
do while (u < shiftl(1_bit_kind,n+m))
|
||||
if (iand(coremask, u) == coremask) then
|
||||
k = k+1
|
||||
psi_det_alpha_unique(1,k) = u
|
||||
endif
|
||||
t = ior(u,u-1)
|
||||
t1 = t+1
|
||||
IRP_IF WITHOUT_TRAILZ
|
||||
t2 = shiftr((iand(not(t),t1)-1), popcnt(ieor(u,u-1)))
|
||||
IRP_ELSE
|
||||
t2 = shiftr((iand(not(t),t1)-1), trailz(u)+1)
|
||||
IRP_ENDIF
|
||||
u = ior(t1,t2)
|
||||
enddo
|
||||
|
||||
|
||||
call configuration_to_dets_size(o,n_det_beta_unique,elec_beta_num-ncore,N_int)
|
||||
TOUCH n_det_beta_unique
|
||||
|
||||
k=0
|
||||
n = elec_beta_num
|
||||
m = mo_num - n
|
||||
u = shiftl(1_bit_kind,n) -1
|
||||
do while (u < shiftl(1_bit_kind,n+m))
|
||||
if (iand(coremask, u) == coremask) then
|
||||
k = k+1
|
||||
psi_det_beta_unique(1,k) = u
|
||||
endif
|
||||
t = ior(u,u-1)
|
||||
t1 = t+1
|
||||
IRP_IF WITHOUT_TRAILZ
|
||||
t2 = shiftr((iand(not(t),t1)-1), popcnt(ieor(u,u-1)))
|
||||
IRP_ELSE
|
||||
t2 = shiftr((iand(not(t),t1)-1), trailz(u)+1)
|
||||
IRP_ENDIF
|
||||
u = ior(t1,t2)
|
||||
enddo
|
||||
|
||||
call generate_all_alpha_beta_det_products
|
||||
|
||||
print *, N_det
|
||||
|
||||
|
||||
end
|
||||
|
||||
53
devel/mpn/mpn.irp.f
Normal file
53
devel/mpn/mpn.irp.f
Normal file
@ -0,0 +1,53 @@
|
||||
program mpn
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
integer :: i, k, l
|
||||
double precision, allocatable :: c_pert(:,:)
|
||||
double precision, allocatable :: e_pert(:)
|
||||
double precision, allocatable :: hc(:), s2(:)
|
||||
|
||||
n_states_diag = 1
|
||||
TOUCH n_states_diag
|
||||
call generate_fci_space
|
||||
allocate(c_pert(N_det,0:mp_order))
|
||||
allocate(s2(N_det))
|
||||
allocate(e_pert(0:mp_order))
|
||||
e_pert(0) = energy_det_i(1)
|
||||
c_pert(:,:) = 0.d0
|
||||
c_pert(1,0) = 1.d0
|
||||
|
||||
e_pert(1) = hf_energy - e_pert(0) - nuclear_repulsion
|
||||
do k=1,mp_order
|
||||
! H_ij C^(k-1)
|
||||
if (distributed_davidson) then
|
||||
call H_S2_u_0_nstates_zmq (c_pert(1,k),s2,c_pert(1,k-1),1,N_det)
|
||||
else
|
||||
call H_S2_u_0_nstates_openmp(c_pert(1,k),s2,c_pert(1,k-1),1,N_det)
|
||||
endif
|
||||
if (k>1) then
|
||||
e_pert(k) += c_pert(1,k)
|
||||
endif
|
||||
print *, k, e_pert(k), sum(e_pert) + nuclear_repulsion
|
||||
|
||||
c_pert(:,k) = -c_pert(:,k)
|
||||
c_pert(1,k) = 0.d0
|
||||
do l=1,k
|
||||
do i=2,N_det
|
||||
c_pert(i,k) = c_pert(i,k) + e_pert(l) * c_pert(i,k-l)
|
||||
enddo
|
||||
enddo
|
||||
do i=2,N_det
|
||||
c_pert(i,k) = c_pert(i,k) + energy_det_i(i) * c_pert(i,k-1)
|
||||
enddo
|
||||
do i=2,N_det
|
||||
c_pert(i,k) = c_pert(i,k) / (energy_det_i(i) - energy_det_i(1))
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
||||
@ -6,16 +6,13 @@ program e_curve
|
||||
integer, allocatable :: iorder(:)
|
||||
double precision , allocatable :: norm_sort(:)
|
||||
double precision :: e_0(N_states)
|
||||
PROVIDE mo_two_e_integrals_in_map
|
||||
PROVIDE mo_two_e_integrals_in_map mo_one_e_integrals
|
||||
|
||||
nab = n_det_alpha_unique+n_det_beta_unique
|
||||
allocate ( norm_sort(0:nab), iorder(0:nab) )
|
||||
|
||||
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
||||
double precision, allocatable :: u_0(:,:), v_0(:,:)
|
||||
allocate(u_t(N_states,N_det),v_t(N_states,N_det),s_t(N_states,N_det))
|
||||
allocate(u_0(N_states,N_det),v_0(N_states,N_det))
|
||||
|
||||
|
||||
|
||||
norm_sort(0) = 0.d0
|
||||
@ -37,6 +34,7 @@ program e_curve
|
||||
endif
|
||||
|
||||
PROVIDE psi_bilinear_matrix_values nuclear_repulsion
|
||||
|
||||
print *, ''
|
||||
print *, '=============================='
|
||||
print *, 'Energies at different cut-offs'
|
||||
@ -47,16 +45,21 @@ program e_curve
|
||||
print *, '=========================================================='
|
||||
double precision :: thresh
|
||||
integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:)
|
||||
integer :: na, nb
|
||||
thresh = 1.d-10
|
||||
na = n_det_alpha_unique
|
||||
nb = n_det_beta_unique
|
||||
do j=0,nab
|
||||
i = iorder(j)
|
||||
if (i<0) then
|
||||
nb -= 1
|
||||
do k=1,n_det
|
||||
if (psi_bilinear_matrix_columns(k) == -i) then
|
||||
psi_bilinear_matrix_values(k,1) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
na -= 1
|
||||
do k=1,n_det
|
||||
if (psi_bilinear_matrix_rows(k) == i) then
|
||||
psi_bilinear_matrix_values(k,1) = 0.d0
|
||||
@ -67,27 +70,11 @@ program e_curve
|
||||
cycle
|
||||
endif
|
||||
|
||||
u_0 = psi_bilinear_matrix_values(1:N_det,1:N_states)
|
||||
v_t = 0.d0
|
||||
s_t = 0.d0
|
||||
call dtranspose( &
|
||||
u_0, &
|
||||
size(u_0, 1), &
|
||||
u_t, &
|
||||
size(u_t, 1), &
|
||||
N_det, N_states)
|
||||
call H_S2_u_0_nstates_openmp_work(v_t,s_t,u_t,N_states,N_det,1,N_det,0,1)
|
||||
call dtranspose( &
|
||||
v_t, &
|
||||
size(v_t, 1), &
|
||||
v_0, &
|
||||
size(v_0, 1), &
|
||||
N_states, N_det)
|
||||
|
||||
double precision, external :: u_dot_u, u_dot_v
|
||||
do i=1,N_states
|
||||
e_0(i) = u_dot_v(v_t(1,i),u_0(1,i),N_det)/u_dot_u(u_0(1,i),N_det)
|
||||
do k=1,N_states
|
||||
psi_coef(1:N_det,k) = psi_bilinear_matrix_values(1:N_det,k)
|
||||
call dset_order(psi_coef(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
enddo
|
||||
TOUCH psi_det psi_coef
|
||||
|
||||
m = 0
|
||||
do k=1,n_det
|
||||
@ -100,10 +87,18 @@ program e_curve
|
||||
exit
|
||||
endif
|
||||
E = E_0(1) + nuclear_repulsion
|
||||
norm = u_dot_u(u_0(1,1),N_det)
|
||||
print '(E9.1,2X,I8,2X,F10.2,2X,F10.8,2X,F12.6)', thresh, m, &
|
||||
dble( elec_alpha_num**3 + elec_alpha_num**2 * (nab-1) ) / &
|
||||
dble( elec_alpha_num**3 + elec_alpha_num**2 * (j-1)), norm, E
|
||||
|
||||
double precision :: cost0, cost
|
||||
cost0 = elec_alpha_num**3 + elec_beta_num**3
|
||||
cost = (na-1) * elec_alpha_num**2 + &
|
||||
(nb-1) * elec_beta_num**2 + &
|
||||
elec_alpha_num**3 + elec_beta_num**3
|
||||
cost = cost/cost0
|
||||
|
||||
double precision :: u_dot_u
|
||||
norm = dsqrt(u_dot_u(psi_coef(1,1),N_det))
|
||||
print '(E9.1,2X,I8,2X,F10.2,2X,F10.8,2X,F15.10)', thresh, m, &
|
||||
cost, norm, psi_energy(1)
|
||||
thresh = thresh * dsqrt(10.d0)
|
||||
enddo
|
||||
print *, '=========================================================='
|
||||
|
||||
75
devel/qmcchem/qmc_e_curve2.irp.f
Normal file
75
devel/qmcchem/qmc_e_curve2.irp.f
Normal file
@ -0,0 +1,75 @@
|
||||
program e_curve
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer :: i,j,k, kk, nab, m, l
|
||||
double precision :: norm, E, hij, num, ci, cj
|
||||
double precision :: e_0(N_states)
|
||||
double precision, allocatable :: psi_save(:)
|
||||
PROVIDE mo_two_e_integrals_in_map mo_one_e_integrals
|
||||
|
||||
if (.not.read_wf) then
|
||||
stop 'Please set read_wf to true'
|
||||
endif
|
||||
|
||||
PROVIDE psi_bilinear_matrix nuclear_repulsion
|
||||
PROVIDE psi_coef_sorted psi_det psi_coef
|
||||
print *, ''
|
||||
print *, '=============================='
|
||||
print *, 'Energies at different cut-offs'
|
||||
print *, '=============================='
|
||||
print *, ''
|
||||
print *, '=========================================================='
|
||||
print '(A8,2X,A8,2X,A12,2X,A10,2X,A12)', 'Thresh.', 'Ndet', 'Cost', 'Norm', 'E'
|
||||
print *, '=========================================================='
|
||||
double precision :: thresh
|
||||
integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:)
|
||||
thresh = 1.d-10
|
||||
integer :: n_det_prime
|
||||
|
||||
nab = n_det_alpha_unique+n_det_beta_unique
|
||||
|
||||
allocate(psi_save(1:N_det))
|
||||
psi_save(1:N_det) = psi_coef(1:N_det,1)
|
||||
do while (thresh < 1.d0)
|
||||
norm = 0.d0
|
||||
n_det_prime = n_det
|
||||
do k=1,n_det
|
||||
psi_coef(k,1) = psi_save(k)
|
||||
if (dabs(psi_coef(k,1)) < thresh) then
|
||||
psi_coef(k,1) = 0.d0
|
||||
n_det_prime -= 1
|
||||
endif
|
||||
norm = norm + psi_coef(k,1)**2
|
||||
enddo
|
||||
TOUCH psi_coef psi_det
|
||||
norm = norm/dsqrt(norm)
|
||||
psi_coef(:,1) = psi_coef(:,1)/norm
|
||||
|
||||
integer :: na, nb
|
||||
na = 0
|
||||
do k=1,n_det_alpha_unique
|
||||
if (det_alpha_norm(k) > 0.d0) then
|
||||
na += 1
|
||||
endif
|
||||
enddo
|
||||
nb = 0
|
||||
do k=1,n_det_beta_unique
|
||||
if (det_beta_norm(k) > 0.d0) then
|
||||
nb += 1
|
||||
endif
|
||||
enddo
|
||||
E = psi_energy(1)
|
||||
double precision :: cost0, cost
|
||||
cost0 = elec_alpha_num**3 + elec_beta_num**3
|
||||
cost = (na-1) * elec_alpha_num**2 + &
|
||||
(nb-1) * elec_beta_num**2 + &
|
||||
elec_alpha_num**3 + elec_beta_num**3
|
||||
cost = cost/cost0
|
||||
print '(E9.1,2X,I8,2X,F10.2,2X,F10.8,2X,F15.10)', thresh, n_det_prime, &
|
||||
cost, norm, E
|
||||
thresh = thresh * dsqrt(10.d0)
|
||||
enddo
|
||||
print *, '=========================================================='
|
||||
|
||||
end
|
||||
|
||||
166
devel/svdwf/Evar_TruncSVD.irp.f
Normal file
166
devel/svdwf/Evar_TruncSVD.irp.f
Normal file
@ -0,0 +1,166 @@
|
||||
program Evar_TruncSVD
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! study energy variation with truncated SVD
|
||||
END_DOC
|
||||
read_wf = .True.
|
||||
TOUCH read_wf
|
||||
! !!!
|
||||
call run()
|
||||
! !!!
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine run
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, allocatable :: A(:,:), U(:,:), V(:,:), D(:)
|
||||
integer :: r, i, j, k, l, m, n, iter, iter_max
|
||||
double precision, allocatable :: Z(:,:), P(:,:), Yt(:,:), UYt(:,:), r1(:,:)
|
||||
! !!!
|
||||
m = n_det_alpha_unique
|
||||
n = n_det_beta_unique
|
||||
r = n
|
||||
print *, 'matrix:', m,'x',n
|
||||
print *, 'N det:', N_det
|
||||
print *, 'rank = ', r
|
||||
iter_max = 20
|
||||
! !!!
|
||||
allocate( Z(m,r) , P(n,r) ) ! Z(m,r) = A(m,n) @ P(n,r)
|
||||
Z(:,:) = 0.d0
|
||||
! !!!
|
||||
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
|
||||
! first we apply a RSVD for a pre-fixed rank (r)
|
||||
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,r1)
|
||||
allocate(r1(N_det,2))
|
||||
!$OMP DO
|
||||
do l=1,r
|
||||
call random_number(r1)
|
||||
r1(:,1) = dsqrt(-2.d0*dlog(r1(:,1)))
|
||||
r1(:,1) = r1(:,1) * dcos(dtwo_pi*r1(:,2))
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
Z(i,l) = Z(i,l) + psi_bilinear_matrix_values(k,1) * r1(k,1)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
deallocate(r1)
|
||||
!$OMP END PARALLEL
|
||||
! !!!
|
||||
! Power iterations
|
||||
! !!!
|
||||
do iter=1,iter_max
|
||||
! !!!
|
||||
print *, 'Power iteration ', iter, '/', 20
|
||||
! !!!
|
||||
! P(n,r) = At(n,m) @ Z(m,r)
|
||||
! !!!
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||
!$OMP DO
|
||||
do l=1,r
|
||||
P(:,l) = 0.d0
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
P(j,l) = P(j,l) + psi_bilinear_matrix_values(k,1) * Z(i,l)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
! !!!
|
||||
! Z(m,r) = A(m,n) @ P(n,r)
|
||||
! !!!
|
||||
!$OMP BARRIER
|
||||
!$OMP DO
|
||||
do l=1,r
|
||||
Z(:,l) = 0.d0
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
Z(i,l) = Z(i,l) + psi_bilinear_matrix_values(k,1) * P(j,l)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
! !!!
|
||||
! Compute QR: at return: Q is Z(m,r)
|
||||
! !!!
|
||||
call ortho_qr(Z,size(Z,1),m,r)
|
||||
! !!!
|
||||
enddo
|
||||
! !!!
|
||||
! Y(r,n) = Zt(r,m) @ A(m,n) or Yt(n,r) = At(n,m) @ Z(m,r)
|
||||
! !!!
|
||||
allocate(Yt(n,r))
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||
!$OMP DO
|
||||
do l=1,r
|
||||
do k=1,n
|
||||
Yt(k,l) = 0.d0
|
||||
enddo
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
Yt(j,l) = Yt(j,l) + Z(i,l) * psi_bilinear_matrix_values(k,1)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
! !!!
|
||||
! Y = UY @ D @ Vt or Yt = V @ Dt @ UYt
|
||||
! !!!
|
||||
allocate(D(r),V(n,r), UYt(r,r))
|
||||
! !!!
|
||||
call svd(Yt,size(Yt,1),V,size(V,1),D,UYt,size(UYt,1),n,r)
|
||||
deallocate(Yt)
|
||||
! !!!
|
||||
! U(m,r) = Z(m,r) @ UY(r,r) or U = Z @ (UYt).T
|
||||
! !!!
|
||||
allocate(U(m,r))
|
||||
call dgemm('N','T',m,r,r,1.d0,Z,size(Z,1),UYt,size(UYt,1),0.d0,U,size(U,1))
|
||||
deallocate(UYt,Z)
|
||||
! !!!
|
||||
!do i=1,r
|
||||
! print *, i, real(D(i)), real(D(i)**2), real(sum(D(1:i)**2))
|
||||
! if (D(i) < 1.d-15) then
|
||||
! k = i
|
||||
! exit
|
||||
! endif
|
||||
!enddo
|
||||
!print *, 'threshold: ', 2.858 * D(k/2)
|
||||
! !!!
|
||||
! Build the new determinant: U @ D @ Vt
|
||||
! !!!
|
||||
!!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||
!!$OMP DO
|
||||
!!
|
||||
!print *, 'ok 1'
|
||||
!N_det = m * n
|
||||
!print *, 'ok 11'
|
||||
!TOUCH N_det
|
||||
!psi_bilinear_matrix_values(:,1) = 0.d0
|
||||
!TOUCH psi_bilinear_matrix_values
|
||||
! print *, size(psi_bilinear_matrix_values,1), size(D), size(U,1), size(U,2), size(V,1), size(V,2)
|
||||
print*, PSI_energy(1) + nuclear_repulsion
|
||||
psi_bilinear_matrix(:,:,:) = 0.d0
|
||||
do r = 1, n
|
||||
call generate_all_alpha_beta_det_products
|
||||
do i = 1, N_det_beta_unique
|
||||
do j = 1, N_det_alpha_unique
|
||||
psi_bilinear_matrix(j,i,1) = 0.d0
|
||||
do l = 1, r
|
||||
psi_bilinear_matrix(j,i,1) = psi_bilinear_matrix(j,i,1) + D(l) * U(j,l) * V(i,l)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
TOUCH psi_bilinear_matrix
|
||||
call update_wf_of_psi_bilinear_matrix(.False.)
|
||||
print*, r, PSI_energy(1) + nuclear_repulsion, s2_values(1) !CI_energy(1)
|
||||
call save_wavefunction()
|
||||
enddo
|
||||
deallocate(U,D,V)
|
||||
! !!!
|
||||
end
|
||||
@ -1 +1,2 @@
|
||||
determinants
|
||||
davidson_undressed
|
||||
|
||||
13
devel/svdwf/ab_products.irp.f
Normal file
13
devel/svdwf/ab_products.irp.f
Normal file
@ -0,0 +1,13 @@
|
||||
program abproducts
|
||||
implicit none
|
||||
read_wf = .True.
|
||||
TOUCH read_wf
|
||||
call run
|
||||
end
|
||||
|
||||
subroutine run
|
||||
implicit none
|
||||
call generate_all_alpha_beta_det_products
|
||||
call diagonalize_ci
|
||||
call save_wavefunction
|
||||
end
|
||||
465
devel/svdwf/buildpsi_diagSVDit_modif_v2.irp.f
Normal file
465
devel/svdwf/buildpsi_diagSVDit_modif_v2.irp.f
Normal file
@ -0,0 +1,465 @@
|
||||
program buildpsi_diagSVDit_modif_v2
|
||||
|
||||
implicit none
|
||||
|
||||
BEGIN_DOC
|
||||
! perturbative approach to build psi_postsvd
|
||||
END_DOC
|
||||
|
||||
read_wf = .True.
|
||||
TOUCH read_wf
|
||||
|
||||
PROVIDE N_int
|
||||
|
||||
call run()
|
||||
end
|
||||
|
||||
|
||||
subroutine run
|
||||
|
||||
USE OMP_LIB
|
||||
|
||||
implicit none
|
||||
|
||||
integer(bit_kind) :: det1(N_int,2), det2(N_int,2)
|
||||
integer :: degree, i_state
|
||||
|
||||
integer :: i, j, k, l, ii, jj, na, nb
|
||||
|
||||
double precision :: norm_psi, inv_sqrt_norm_psi
|
||||
double precision, allocatable :: Uref(:,:), Dref(:), Vtref(:,:), Aref(:,:), Vref(:,:)
|
||||
|
||||
double precision :: err0, err_tmp, e_tmp, E0, overlap, E0_old, tol_energy
|
||||
double precision :: ctmp, htmp, Ept2
|
||||
double precision :: E0_postsvd, overlap_postsvd, E_prev
|
||||
double precision :: norm_coeff_psi, inv_sqrt_norm_coeff_psi
|
||||
double precision :: overlapU, overlapU_mat, overlapV, overlapV_mat, overlap_psi
|
||||
|
||||
double precision, allocatable :: H_diag(:,:), Hkl(:,:), H0(:,:), H(:,:,:,:)
|
||||
double precision, allocatable :: psi_postsvd(:,:), coeff_psi_perturb(:)
|
||||
|
||||
integer :: n_FSVD, n_selected, n_toselect, n_tmp, it_svd, it_svd_max
|
||||
integer :: n_selected2
|
||||
integer, allocatable :: numalpha_selected(:), numbeta_selected(:)
|
||||
integer, allocatable :: numalpha_toselect(:), numbeta_toselect(:)
|
||||
integer, allocatable :: numalpha_tmp(:), numbeta_tmp(:)
|
||||
|
||||
integer(kind=8) :: W_tbeg, W_tend, W_tbeg_it, W_tend_it, W_ir
|
||||
real(kind=8) :: W_tot_time, W_tot_time_it
|
||||
real(kind=8) :: CPU_tbeg, CPU_tend, CPU_tbeg_it, CPU_tend_it
|
||||
real(kind=8) :: CPU_tot_time, CPU_tot_time_it
|
||||
real(kind=8) :: speedup, speedup_it
|
||||
integer :: nb_taches
|
||||
|
||||
!$OMP PARALLEL
|
||||
nb_taches = OMP_GET_NUM_THREADS()
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call CPU_TIME(CPU_tbeg)
|
||||
call SYSTEM_CLOCK(COUNT=W_tbeg, COUNT_RATE=W_ir)
|
||||
|
||||
i_state = 1
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
! construct the initial CISD matrix
|
||||
|
||||
print *, ' ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~'
|
||||
print *, ' CI matrix:', n_det_alpha_unique,'x',n_det_beta_unique
|
||||
print *, ' N det :', N_det
|
||||
print *, ' ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~'
|
||||
|
||||
norm_psi = 0.d0
|
||||
do k = 1, N_det
|
||||
norm_psi = norm_psi + psi_bilinear_matrix_values(k,i_state) &
|
||||
* psi_bilinear_matrix_values(k,i_state)
|
||||
enddo
|
||||
print *, ' initial norm = ', norm_psi
|
||||
|
||||
allocate( Aref(n_det_alpha_unique,n_det_beta_unique) )
|
||||
Aref(:,:) = 0.d0
|
||||
do k = 1, N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
Aref(i,j) = psi_bilinear_matrix_values(k,i_state)
|
||||
enddo
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
! perform a Full SVD
|
||||
|
||||
allocate( Uref(n_det_alpha_unique,n_det_alpha_unique) )
|
||||
allocate( Dref(max(n_det_beta_unique,n_det_alpha_unique)) )
|
||||
allocate( Vref(n_det_beta_unique,n_det_beta_unique) )
|
||||
allocate( Vtref(n_det_beta_unique,n_det_beta_unique) )
|
||||
call svd_s(Aref, size(Aref,1), Uref, size(Uref,1), Dref, Vtref, size(Vtref,1) &
|
||||
, n_det_alpha_unique, n_det_beta_unique)
|
||||
|
||||
print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
|
||||
|
||||
do l = 1, n_det_beta_unique
|
||||
do i = 1, n_det_beta_unique
|
||||
Vref(i,l) = Vtref(l,i)
|
||||
enddo
|
||||
enddo
|
||||
deallocate( Vtref )
|
||||
|
||||
! Truncated rank
|
||||
n_selected = 10 ! n_svd
|
||||
call write_int(6,n_selected, 'Rank of psi')
|
||||
|
||||
|
||||
!________________________________________________________________________________________________________
|
||||
!
|
||||
! loop over SVD iterations
|
||||
!________________________________________________________________________________________________________
|
||||
|
||||
tol_energy = 1.d0
|
||||
it_svd = 0
|
||||
it_svd_max = 100
|
||||
E_prev = 0.d0
|
||||
|
||||
allocate(H(n_selected,n_selected,n_det_alpha_unique,n_det_beta_unique))
|
||||
allocate(H_diag(n_det_alpha_unique,n_det_beta_unique))
|
||||
allocate(psi_postsvd(n_det_alpha_unique,n_det_beta_unique))
|
||||
do while( ( it_svd .lt. it_svd_max) .and. ( tol_energy .gt. 1d-6 ) )
|
||||
|
||||
call CPU_TIME(CPU_tbeg_it)
|
||||
call SYSTEM_CLOCK(COUNT=W_tbeg_it, COUNT_RATE=W_ir)
|
||||
|
||||
it_svd = it_svd + 1
|
||||
|
||||
double precision :: norm
|
||||
norm = 0.d0
|
||||
do j = 1, n_selected
|
||||
norm = norm + Dref(j)*Dref(j)
|
||||
enddo
|
||||
Dref = Dref / dsqrt(norm)
|
||||
|
||||
! print *, '-- Compute H --'
|
||||
call const_H_uv(Uref, Vref, H, H_diag, n_selected)
|
||||
|
||||
! H0(i,j) = < u_i v_j | H | u_i v_j >
|
||||
! E0 = < psi_0 | H | psi_0 >
|
||||
E0 = 0.d0
|
||||
do j = 1, n_selected
|
||||
do i = 1, n_selected
|
||||
E0 = E0 + Dref(i) * H(i,i,j,j) * Dref(j)
|
||||
enddo
|
||||
enddo
|
||||
E0 = E0 + nuclear_repulsion
|
||||
! print *,' E0 =', E0
|
||||
|
||||
double precision, allocatable :: eigval0(:)
|
||||
double precision, allocatable :: eigvec0(:,:,:)
|
||||
double precision, allocatable :: H_tmp(:,:,:,:)
|
||||
|
||||
allocate( H_tmp(n_selected,n_selected,n_selected,n_selected) )
|
||||
do l=1,n_selected
|
||||
do k=1,n_selected
|
||||
do j=1,n_selected
|
||||
do i=1,n_selected
|
||||
H_tmp(i,j,k,l) = H(i,j,k,l)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
allocate( eigval0(n_selected**2),eigvec0(n_selected,n_selected,n_selected**2))
|
||||
eigvec0 = 0.d0
|
||||
|
||||
! print *, ' --- Diag post-SVD --- '
|
||||
call lapack_diag(eigval0, eigvec0, H_tmp, n_selected**2, n_selected**2)
|
||||
! print *, 'eig =', eigval0(1) + nuclear_repulsion
|
||||
deallocate(H_tmp, eigval0)
|
||||
|
||||
! print *, ' --- SVD --- '
|
||||
Dref = 0.d0
|
||||
call perform_newpostSVD(n_selected, eigvec0(1,1,1), Uref, Vref, Dref)
|
||||
deallocate(eigvec0)
|
||||
|
||||
! print *, ' --- Compute H --- '
|
||||
call const_H_uv(Uref, Vref, H, H_diag, n_selected)
|
||||
|
||||
! H0(i,j) = < u_i v_j | H | u_i v_j >
|
||||
! E0 = < psi_0 | H | psi_0 >
|
||||
E0 = 0.d0
|
||||
norm = 0.d0
|
||||
do j = 1, n_det_beta_unique
|
||||
do i = 1, n_selected
|
||||
E0 = E0 + Dref(i) * H(i,i,j,j) * Dref(j)
|
||||
enddo
|
||||
norm = norm + Dref(j)*Dref(j)
|
||||
enddo
|
||||
E0 = E0 + nuclear_repulsion
|
||||
! print *,' E0 =', E0
|
||||
! print *,' norm =', norm
|
||||
|
||||
! print *, ' --- Perturbation --- '
|
||||
psi_postsvd = 0.d0
|
||||
do i=1,n_selected
|
||||
psi_postsvd(i,i) = Dref(i)
|
||||
enddo
|
||||
|
||||
Ept2 = 0.d0
|
||||
do j=1,n_selected
|
||||
do i=n_selected+1,n_det_alpha_unique
|
||||
ctmp = 0.d0
|
||||
do l=1,n_selected
|
||||
do k=1,n_selected
|
||||
ctmp = ctmp + H(k,l,i,j) * psi_postsvd(k,l)
|
||||
enddo
|
||||
enddo
|
||||
psi_postsvd(i,j) = ctmp / (E0 - (H_diag(i,j)+nuclear_repulsion) )
|
||||
Ept2 += ctmp*ctmp / (E0 - (H_diag(i,j)+nuclear_repulsion) )
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do j=n_selected+1,n_det_beta_unique
|
||||
do i=1,n_selected
|
||||
ctmp = 0.d0
|
||||
do l=1,n_selected
|
||||
do k=1,n_selected
|
||||
ctmp = ctmp + H(k,l,i,j) * psi_postsvd(k,l)
|
||||
enddo
|
||||
enddo
|
||||
psi_postsvd(i,j) = ctmp / (E0 - (H_diag(i,j)+nuclear_repulsion) )
|
||||
Ept2 += ctmp*ctmp / (E0 - (H_diag(i,j)+nuclear_repulsion) )
|
||||
enddo
|
||||
enddo
|
||||
|
||||
tol_energy = dabs(E_prev - E0)
|
||||
print '(I5, 3(3X, F20.10))', it_svd, E0, E0 + Ept2, tol_energy
|
||||
E_prev = E0
|
||||
|
||||
! print *, ' --- SVD --- '
|
||||
call perform_newpostSVD(n_det_beta_unique, psi_postsvd, Uref, Vref, Dref)
|
||||
|
||||
end do
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine perform_newpostSVD(n_selected, psi_postsvd, Uref, Vref, Dref)
|
||||
|
||||
USE OMP_LIB
|
||||
|
||||
integer, intent(in) :: n_selected
|
||||
double precision, intent(in) :: psi_postsvd(n_selected,n_selected)
|
||||
double precision, intent(inout) :: Uref(n_det_alpha_unique,n_det_alpha_unique)
|
||||
double precision, intent(inout) :: Vref(n_det_beta_unique ,n_det_beta_unique)
|
||||
double precision, intent(inout) :: Dref(max(n_det_beta_unique,n_det_alpha_unique))
|
||||
|
||||
integer :: mm, nn, i, j, ii0, ii, l, jj, na, nb
|
||||
double precision :: err0, err_norm, err_tmp, norm_tmp
|
||||
double precision :: overlapU_mat, overlapV_mat, overlapU, overlapV
|
||||
double precision, allocatable :: S_mat(:,:), SxVt(:,:)
|
||||
double precision, allocatable :: U_svd(:,:), V_svd(:,:)
|
||||
double precision, allocatable :: U_newsvd(:,:), V_newsvd(:,:), Vt_newsvd(:,:), D_newsvd(:), A_newsvd(:,:)
|
||||
|
||||
mm = n_det_alpha_unique
|
||||
nn = n_det_beta_unique
|
||||
|
||||
allocate( U_svd(mm,n_selected) , V_svd(nn,n_selected) , S_mat(n_selected,n_selected) )
|
||||
|
||||
U_svd(1:mm,1:n_selected) = Uref(1:mm,1:n_selected)
|
||||
V_svd(1:nn,1:n_selected) = Vref(1:nn,1:n_selected)
|
||||
|
||||
S_mat(1:n_selected,1:n_selected) = psi_postsvd(1:n_selected,1:n_selected)
|
||||
|
||||
! first compute S_mat x transpose(V_svd)
|
||||
allocate( SxVt(n_selected,nn) )
|
||||
call dgemm( 'N', 'T', n_selected, nn, n_selected, 1.d0 &
|
||||
, S_mat , size(S_mat,1) &
|
||||
, V_svd , size(V_svd,1) &
|
||||
, 0.d0, SxVt, size(SxVt ,1) )
|
||||
deallocate(S_mat)
|
||||
|
||||
! then compute U_svd x SxVt
|
||||
allocate( A_newsvd(mm,nn) )
|
||||
call dgemm( 'N', 'N', mm, nn, n_selected, 1.d0 &
|
||||
, U_svd , size(U_svd ,1) &
|
||||
, SxVt , size(SxVt ,1) &
|
||||
, 0.d0, A_newsvd, size(A_newsvd,1) )
|
||||
deallocate( SxVt )
|
||||
|
||||
! perform new SVD
|
||||
allocate( U_newsvd(mm,mm), Vt_newsvd(nn,nn), D_newsvd(max(mm,nn)) )
|
||||
call svd_s( A_newsvd, size(A_newsvd,1), &
|
||||
U_newsvd, size(U_newsvd,1), &
|
||||
D_newsvd, &
|
||||
Vt_newsvd, size(Vt_newsvd,1), &
|
||||
mm, nn)
|
||||
deallocate(A_newsvd)
|
||||
|
||||
allocate( V_newsvd(nn,nn) )
|
||||
do l = 1, nn
|
||||
do j = 1, nn
|
||||
V_newsvd(j,l) = Vt_newsvd(l,j)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(Vt_newsvd)
|
||||
|
||||
do l = 1, n_selected
|
||||
Dref(l) = D_newsvd(l)
|
||||
Uref(1:mm,l) = U_newsvd(1:mm,l)
|
||||
Vref(1:nn,l) = V_newsvd(1:nn,l)
|
||||
enddo
|
||||
|
||||
deallocate(U_newsvd)
|
||||
deallocate(V_newsvd)
|
||||
deallocate(D_newsvd)
|
||||
|
||||
end subroutine perform_newpostSVD
|
||||
|
||||
|
||||
|
||||
subroutine const_H_uv(Uref, Vref, H, H_diag, n_selected)
|
||||
|
||||
USE OMP_LIB
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n_selected
|
||||
double precision, intent(in) :: Uref(n_det_alpha_unique,n_det_alpha_unique)
|
||||
double precision, intent(in) :: Vref(n_det_beta_unique ,n_det_beta_unique)
|
||||
double precision, intent(out) :: H(n_selected,n_selected, n_det_alpha_unique, n_det_beta_unique)
|
||||
double precision, intent(out) :: H_diag(n_det_alpha_unique,n_det_beta_unique)
|
||||
|
||||
integer(bit_kind) :: det1(N_int,2), det2(N_int,2)
|
||||
integer :: i, j, k, l, degree
|
||||
integer :: ii0, jj0, ii, jj, n, m, np, mp
|
||||
integer :: nn0, mm0, na, nb, mm, ind_gs
|
||||
integer :: p,q,r,s
|
||||
double precision :: h12, x
|
||||
|
||||
double precision, allocatable :: H0(:,:,:,:)
|
||||
double precision, allocatable :: H1(:,:,:,:)
|
||||
double precision, allocatable :: tmp3(:,:,:)
|
||||
double precision, allocatable :: tmp1(:,:), tmp0(:,:)
|
||||
double precision :: c_tmp
|
||||
|
||||
|
||||
na = n_det_alpha_unique
|
||||
nb = n_det_beta_unique
|
||||
|
||||
det1(:,1) = psi_det_alpha_unique(:,1)
|
||||
det2(:,1) = psi_det_alpha_unique(:,1)
|
||||
det1(:,2) = psi_det_beta_unique(:,1)
|
||||
det2(:,2) = psi_det_beta_unique(:,1)
|
||||
call i_H_j(det1, det2, N_int, h12)
|
||||
|
||||
call wall_time(t0)
|
||||
tmp3 = 0.d0
|
||||
|
||||
allocate( H0(na,nb,n_selected,n_selected) )
|
||||
allocate (tmp3(nb,nb,nb))
|
||||
H0 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(i,j,k,l,m,n,det1,det2,degree,h12,c_tmp,tmp1,tmp0)&
|
||||
!$OMP SHARED(na,nb,psi_det_alpha_unique,psi_det_beta_unique,&
|
||||
!$OMP N_int,tmp3,Uref,Vref,H_diag,H0,n_selected)
|
||||
|
||||
allocate(tmp1(na,na), tmp0(na,na))
|
||||
|
||||
do i=1,na
|
||||
do m=1,na
|
||||
tmp1(m,i) = Uref(i,m)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!$OMP DO
|
||||
do l = 1, nb
|
||||
det2(:,2) = psi_det_beta_unique(:,l)
|
||||
|
||||
do j = 1, nb
|
||||
det1(:,2) = psi_det_beta_unique(:,j)
|
||||
|
||||
call get_excitation_degree_spin(det1(1,2),det2(1,2),degree,N_int)
|
||||
if (degree > 2) cycle
|
||||
|
||||
do k = 1, na
|
||||
det2(:,1) = psi_det_alpha_unique(:,k)
|
||||
|
||||
do i = 1, na
|
||||
det1(:,1) = psi_det_alpha_unique(:,i)
|
||||
|
||||
call get_excitation_degree(det1,det2,degree,N_int)
|
||||
if ( degree > 2) cycle
|
||||
|
||||
call i_H_j(det1, det2, N_int, h12)
|
||||
if (h12 == 0.d0) cycle
|
||||
|
||||
do m=1,nb
|
||||
tmp3(m,j,l) = tmp3(m,j,l) + h12 * tmp1(m,i) * tmp1(m,k)
|
||||
enddo
|
||||
|
||||
do n=1,n_selected
|
||||
c_tmp = h12 * Vref(j,n)
|
||||
if (c_tmp == 0.d0) cycle
|
||||
do m=1,n_selected
|
||||
H0(k,l,m,n) = H0(k,l,m,n) + c_tmp * tmp1(m,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
|
||||
!$OMP DO
|
||||
do m=1,nb
|
||||
do l=1,nb
|
||||
do j=1,nb
|
||||
tmp1(j,l) = tmp3(m,j,l)
|
||||
enddo
|
||||
enddo
|
||||
call DGEMM('N','N',nb,nb,nb,1.d0, &
|
||||
tmp1, size(tmp1,1), &
|
||||
Vref, size(Vref,1), &
|
||||
0.d0, tmp0, size(tmp0,1))
|
||||
|
||||
do n=1,nb
|
||||
H_diag(m,n) = 0.d0
|
||||
do j=1,nb
|
||||
H_diag(m,n) = H_diag(m,n) + tmp0(j,n) * Vref(j,n)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
deallocate(tmp1, tmp0)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(t1)
|
||||
|
||||
|
||||
allocate( H1(nb,n_selected,n_selected,na) )
|
||||
call DGEMM('T','N', nb * n_selected * n_selected, na, na, &
|
||||
1.d0, H0, size(H0,1), Uref, size(Uref,1), 0.d0, H1, size(H1,1)*size(H1,2)*size(H1,3))
|
||||
deallocate( H0 )
|
||||
|
||||
! (l,p,q,r) -> (p,q,r,s)
|
||||
call DGEMM('T','N', n_selected * n_selected * na, nb, nb, &
|
||||
1.d0, H1, size(H1,1), Vref, size(Vref,1), 0.d0, H, size(H,1)*size(H,2)*size(H,3))
|
||||
|
||||
! do j=1,n_selected
|
||||
! do i=1,n_selected
|
||||
! print *, H_diag(i,j), H(i,j,i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
deallocate(H1)
|
||||
|
||||
call wall_time(t2)
|
||||
! print *, 't=', t1-t0, t2-t1
|
||||
double precision :: t0, t1, t2
|
||||
! stop
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -23,7 +23,11 @@ subroutine run
|
||||
allocate(Z(m,r))
|
||||
|
||||
! Z(m,r) = A(m,n).P(n,r)
|
||||
Z(:,:) = 0.d0
|
||||
do j=1,r
|
||||
do i=1,m
|
||||
Z(i,j) = 0.d0
|
||||
enddo
|
||||
enddo
|
||||
allocate(P(n,r))
|
||||
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,r1)
|
||||
@ -84,7 +88,9 @@ subroutine run
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||
!$OMP DO
|
||||
do l=1,r
|
||||
Yt(:,l) = 0.d0
|
||||
do k=1,n
|
||||
Yt(k,l) = 0.d0
|
||||
enddo
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
|
||||
@ -12,36 +12,57 @@ subroutine run
|
||||
implicit none
|
||||
double precision, allocatable :: U(:,:), Vt(:,:), D(:), A(:,:)
|
||||
integer :: i, j, k, p, q
|
||||
double precision :: entropy
|
||||
|
||||
allocate( A (n_det_alpha_unique, n_det_beta_unique), &
|
||||
U (n_det_alpha_unique, n_det_alpha_unique), &
|
||||
Vt(n_det_beta_unique, n_det_beta_unique), &
|
||||
D(max(n_det_beta_unique,n_det_alpha_unique)) )
|
||||
|
||||
A = 0.D0
|
||||
do j=1,n_det_beta_unique
|
||||
do i=1,n_det_alpha_unique
|
||||
A(i,j) = 0.D0
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
A(i,j) = psi_bilinear_matrix_values(k,1)
|
||||
enddo
|
||||
|
||||
call randomized_svd(A, size(A,1), &
|
||||
if (N_det == 1) then
|
||||
D(1) = 1.d0
|
||||
U(1,1) = 1.d0
|
||||
Vt(1,1) = 1.d0
|
||||
else
|
||||
call randomized_svd(A, size(A,1), &
|
||||
U, size(U,1), D, Vt, size(Vt,1), n_det_alpha_unique, n_det_beta_unique, &
|
||||
6,1000)
|
||||
6,min(n_det_beta_unique,1000))
|
||||
endif
|
||||
|
||||
entropy = 0.d0
|
||||
do i=1,n_det_beta_unique
|
||||
print *, i, real(D(i)), real(D(i)**2), real(sum(D(1:i)**2))
|
||||
entropy -= D(i) * dlog(D(i))
|
||||
if (D(i) < 1.d-15) then
|
||||
k = i
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
print *, 'threshold: ', 2.858 * D(k/2)
|
||||
do i=1,n_det_alpha_unique
|
||||
print '(I6,4(X,F12.8))', i, U(i,1:4)
|
||||
enddo
|
||||
print *, ''
|
||||
do i=1,n_det_beta_unique
|
||||
print '(I6,4(X,F12.8))', i, Vt(1:4,i)
|
||||
enddo
|
||||
print *, 'Entropy : ', entropy
|
||||
|
||||
call ezfio_set_spindeterminants_psi_svd_alpha(U)
|
||||
call ezfio_set_spindeterminants_psi_svd_beta (Vt)
|
||||
call ezfio_set_spindeterminants_psi_svd_coefs(D)
|
||||
|
||||
! do i=1,n_det_alpha_unique
|
||||
! print '(I6,4(X,F12.8))', i, U(i,1:4)
|
||||
! enddo
|
||||
! print *, ''
|
||||
! do i=1,n_det_beta_unique
|
||||
! print '(I6,4(X,F12.8))', i, Vt(1:4,i)
|
||||
! enddo
|
||||
|
||||
end
|
||||
|
||||
12
devel/trexio/EZFIO.cfg
Normal file
12
devel/trexio/EZFIO.cfg
Normal file
@ -0,0 +1,12 @@
|
||||
[backend]
|
||||
type: integer
|
||||
doc: Back-end used in TREXIO. 0: HDF5, 1:Text
|
||||
interface: ezfio, ocaml, provider
|
||||
default: 0
|
||||
|
||||
[trexio_file]
|
||||
type: character*(256)
|
||||
doc: Name of the exported TREXIO file
|
||||
interface: ezfio, ocaml, provider
|
||||
default: None
|
||||
|
||||
2
devel/trexio/LIB
Normal file
2
devel/trexio/LIB
Normal file
@ -0,0 +1,2 @@
|
||||
-L/home/scemama/TREX/trexio/_install/lib -ltrexio
|
||||
|
||||
6
devel/trexio/NEED
Normal file
6
devel/trexio/NEED
Normal file
@ -0,0 +1,6 @@
|
||||
ezfio_files
|
||||
determinants
|
||||
mo_one_e_ints
|
||||
mo_two_e_ints
|
||||
ao_two_e_ints
|
||||
ao_one_e_ints
|
||||
4
devel/trexio/README.rst
Normal file
4
devel/trexio/README.rst
Normal file
@ -0,0 +1,4 @@
|
||||
======
|
||||
trexio
|
||||
======
|
||||
|
||||
262
devel/trexio/export_trexio.irp.f
Normal file
262
devel/trexio/export_trexio.irp.f
Normal file
@ -0,0 +1,262 @@
|
||||
program export_trexio
|
||||
use trexio
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Exports the wave function in TREXIO format
|
||||
END_DOC
|
||||
|
||||
integer(8) :: f ! TREXIO file handle
|
||||
integer :: rc
|
||||
|
||||
print *, 'TREXIO file : '//trim(trexio_filename)
|
||||
print *, ''
|
||||
|
||||
if (backend == 0) then
|
||||
f = trexio_open(trexio_filename, 'w', TREXIO_HDF5)
|
||||
else if (backend == 1) then
|
||||
f = trexio_open(trexio_filename, 'w', TREXIO_TEXT)
|
||||
endif
|
||||
if (f == 0) then
|
||||
print *, 'Unable to open TREXIO file for writing'
|
||||
stop -1
|
||||
endif
|
||||
|
||||
! ------------------------------------------------------------------------------
|
||||
|
||||
! Electrons
|
||||
! ---------
|
||||
|
||||
rc = trexio_write_electron_up_num(f, elec_alpha_num)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_electron_dn_num(f, elec_beta_num)
|
||||
call check_success(rc)
|
||||
|
||||
|
||||
! Nuclei
|
||||
! ------
|
||||
|
||||
rc = trexio_write_nucleus_num(f, nucl_num)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_nucleus_charge(f, nucl_charge)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_nucleus_coord(f, nucl_coord_transp)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_nucleus_label(f, nucl_label, 32)
|
||||
call check_success(rc)
|
||||
|
||||
|
||||
! Pseudo-potentials
|
||||
! -----------------
|
||||
|
||||
double precision, allocatable :: tmp_double(:,:)
|
||||
integer, allocatable :: tmp_int(:,:)
|
||||
|
||||
! rc = trexio_write_ecp_lmax_plus_1(f, pseudo_lmax+1)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_z_core(f, nucl_charge_remove)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_local_num_n_max(f, pseudo_klocmax)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_local_power(f, pseudo_n_k_transp)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_local_exponent(f, pseudo_dz_k_transp)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_local_coef(f, pseudo_v_k_transp)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_non_local_num_n_max(f, pseudo_kmax)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_non_local_power(f, pseudo_n_kl_transp)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_non_local_exponent(f, pseudo_dz_kl_transp)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_ecp_non_local_coef(f, pseudo_v_kl_transp)
|
||||
! call check_success(rc)
|
||||
|
||||
|
||||
|
||||
! Basis
|
||||
! -----
|
||||
|
||||
rc = trexio_write_basis_type(f, 'Gaussian', len('Gaussian'))
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_num(f, shell_num)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_nucleus_shell_num(f, nucleus_shell_num)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_nucleus_index(f, basis_nucleus_index)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_shell_ang_mom(f, shell_ang_mom)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_prim_num(f, prim_num)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_shell_prim_num(f, shell_prim_num)
|
||||
call check_success(rc)
|
||||
|
||||
double precision, allocatable :: factor(:)
|
||||
allocate(factor(shell_num))
|
||||
if (ao_normalized) then
|
||||
factor(1:shell_num) = shell_normalization_factor(1:shell_num)
|
||||
else
|
||||
factor(1:shell_num) = 1.d0
|
||||
endif
|
||||
rc = trexio_write_basis_shell_factor(f, factor)
|
||||
call check_success(rc)
|
||||
deallocate(factor)
|
||||
|
||||
rc = trexio_write_basis_shell_prim_index(f, shell_prim_index)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_exponent(f, prim_expo)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_basis_coefficient(f, prim_coef)
|
||||
call check_success(rc)
|
||||
|
||||
allocate(factor(prim_num))
|
||||
if (primitives_normalized) then
|
||||
factor(1:prim_num) = prim_normalization_factor(1:prim_num)
|
||||
else
|
||||
factor(1:prim_num) = 1.d0
|
||||
endif
|
||||
rc = trexio_write_basis_prim_factor(f, factor)
|
||||
call check_success(rc)
|
||||
deallocate(factor)
|
||||
|
||||
|
||||
|
||||
! Atomic orbitals
|
||||
! ---------------
|
||||
|
||||
rc = trexio_write_ao_num(f, ao_num)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_ao_cartesian(f, 1)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_ao_shell(f, ao_shell)
|
||||
call check_success(rc)
|
||||
|
||||
integer :: i
|
||||
allocate(factor(ao_num))
|
||||
if (ao_normalized) then
|
||||
do i=1,ao_num
|
||||
factor(i) = ao_coef_normalization_factor(i) / shell_normalization_factor( ao_shell(i) )
|
||||
enddo
|
||||
else
|
||||
factor(:) = 1.d0
|
||||
endif
|
||||
rc = trexio_write_ao_normalization(f, factor)
|
||||
call check_success(rc)
|
||||
deallocate(factor)
|
||||
|
||||
! One-e AO integrals
|
||||
! ------------------
|
||||
|
||||
rc = trexio_write_ao_1e_int_overlap(f,ao_overlap)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_ao_1e_int_kinetic(f,ao_kinetic_integrals)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_ao_1e_int_potential_n_e(f,ao_integrals_n_e)
|
||||
call check_success(rc)
|
||||
|
||||
if (do_pseudo) then
|
||||
rc = trexio_write_ao_1e_int_ecp_local(f,ao_pseudo_integrals_local)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_ao_1e_int_ecp_non_local(f,ao_pseudo_integrals_non_local)
|
||||
call check_success(rc)
|
||||
endif
|
||||
|
||||
rc = trexio_write_ao_1e_int_core_hamiltonian(f,ao_one_e_integrals)
|
||||
call check_success(rc)
|
||||
|
||||
|
||||
! Molecular orbitals
|
||||
! ------------------
|
||||
|
||||
! rc = trexio_write_mo_type(f, mo_label)
|
||||
! call check_success(rc)
|
||||
|
||||
rc = trexio_write_mo_num(f, mo_num)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_mo_coefficient(f, mo_coef)
|
||||
call check_success(rc)
|
||||
|
||||
|
||||
! One-e MO integrals
|
||||
! ------------------
|
||||
|
||||
rc = trexio_write_mo_1e_int_kinetic(f,mo_kinetic_integrals)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_mo_1e_int_potential_n_e(f,mo_integrals_n_e)
|
||||
call check_success(rc)
|
||||
|
||||
if (do_pseudo) then
|
||||
rc = trexio_write_mo_1e_int_ecp_local(f,mo_pseudo_integrals_local)
|
||||
call check_success(rc)
|
||||
|
||||
rc = trexio_write_mo_1e_int_ecp_non_local(f,mo_pseudo_integrals_non_local)
|
||||
call check_success(rc)
|
||||
endif
|
||||
!
|
||||
rc = trexio_write_mo_1e_int_core_hamiltonian(f,one_e_dm_mo)
|
||||
call check_success(rc)
|
||||
|
||||
|
||||
! RDM
|
||||
! ----
|
||||
|
||||
! rc = trexio_write_rdm_one_e(f,one_e_dm_mo)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_rdm_one_e_up(f,one_e_dm_mo_alpha_average)
|
||||
! call check_success(rc)
|
||||
!
|
||||
! rc = trexio_write_rdm_one_e_dn(f,one_e_dm_mo_beta_average)
|
||||
! call check_success(rc)
|
||||
|
||||
|
||||
! ------------------------------------------------------------------------------
|
||||
|
||||
rc = trexio_close(f)
|
||||
call check_success(rc)
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine check_success(rc)
|
||||
use trexio
|
||||
implicit none
|
||||
integer, intent(in) :: rc
|
||||
character*(128) :: str
|
||||
if (rc /= TREXIO_SUCCESS) then
|
||||
call trexio_string_of_error(rc,str)
|
||||
print *, 'TREXIO Error: ' //trim(str)
|
||||
stop -1
|
||||
endif
|
||||
end
|
||||
|
||||
! -*- mode: f90 -*-
|
||||
3232
devel/trexio/trexio_f.f90
Normal file
3232
devel/trexio/trexio_f.f90
Normal file
File diff suppressed because it is too large
Load Diff
20
devel/trexio/trexio_file.irp.f
Normal file
20
devel/trexio/trexio_file.irp.f
Normal file
@ -0,0 +1,20 @@
|
||||
BEGIN_PROVIDER [ character*(1024), trexio_filename ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Name of the TREXIO file
|
||||
END_DOC
|
||||
character*(1024) :: prefix
|
||||
|
||||
trexio_filename = trexio_file
|
||||
|
||||
if (trexio_file == 'None') then
|
||||
prefix = trim(ezfio_work_dir)//trim(ezfio_filename)
|
||||
if (backend == 0) then
|
||||
trexio_filename = trim(prefix)//'.h5'
|
||||
else if (backend == 1) then
|
||||
trexio_filename = trim(prefix)
|
||||
endif
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
@ -1,7 +0,0 @@
|
||||
[t1_amplitudes]
|
||||
type: double precision
|
||||
doc: Amplitudes for the single-excitation operator
|
||||
interface: ezfio,provider
|
||||
size: (mo_basis.mo_num,mo_basis.mo_num)
|
||||
|
||||
|
||||
4
stable/utilities/hcore_guess.irp.f
Normal file
4
stable/utilities/hcore_guess.irp.f
Normal file
@ -0,0 +1,4 @@
|
||||
program hcore_guess_prog
|
||||
implicit none
|
||||
call hcore_guess
|
||||
end
|
||||
@ -55,16 +55,16 @@ subroutine routine_s2
|
||||
integer :: i,j,k
|
||||
double precision :: accu(N_states)
|
||||
|
||||
print *, 'Weights of the SOP'
|
||||
print *, 'Weights of the CFG'
|
||||
do i=1,N_det
|
||||
print *, i, real(weight_occ_pattern(det_to_occ_pattern(i),:)), real(sum(weight_occ_pattern(det_to_occ_pattern(i),:)))
|
||||
print *, i, real(weight_configuration(det_to_configuration(i),:)), real(sum(weight_configuration(det_to_configuration(i),:)))
|
||||
enddo
|
||||
print*, 'Min weight of the occupation pattern ?'
|
||||
read(5,*) wmin
|
||||
|
||||
ndet_max = 0
|
||||
do i=1,N_det
|
||||
if (maxval(weight_occ_pattern( det_to_occ_pattern(i),:)) < wmin) cycle
|
||||
if (maxval(weight_configuration( det_to_configuration(i),:)) < wmin) cycle
|
||||
ndet_max = ndet_max+1
|
||||
enddo
|
||||
|
||||
@ -73,7 +73,7 @@ subroutine routine_s2
|
||||
accu = 0.d0
|
||||
k=0
|
||||
do i = 1, N_det
|
||||
if (maxval(weight_occ_pattern( det_to_occ_pattern(i),:)) < wmin) cycle
|
||||
if (maxval(weight_configuration( det_to_configuration(i),:)) < wmin) cycle
|
||||
k = k+1
|
||||
do j = 1, N_int
|
||||
psi_det_tmp(j,1,k) = psi_det(j,1,i)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user