LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-12 16:33:37 +01:00
Code Releases Activity

Compare commits

base: LCPQ:55286d7889d488fa3d2ad4dce5d883e355aacc9a
Branches Tags
LCPQ:master
LCPQ:dev-stable
LCPQ:torus
LCPQ:dev-pbc
LCPQ:dev-spher_harm
LCPQ:macos
LCPQ:dev-stable-tc-scf
LCPQ:dev-stable-rdm
LCPQ:bugfix
LCPQ:dev-stable-pt-charges
LCPQ:dev-broken
LCPQ:good-dev-tc
LCPQ:guix
LCPQ:dev-tc
LCPQ:cleaning_dft
LCPQ:trexio
LCPQ:csf
LCPQ:v1j4y-patch-2
LCPQ:TApplencourt-patch-1
LCPQ:kpts-patch-1
LCPQ:cleaning_kpts
LCPQ:features_kpts
LCPQ:kgasperich-patch-2
LCPQ:kgasperich-patch-1
LCPQ:features_periodic
LCPQ:features_spack
LCPQ:daily-test
LCPQ:biblio
LCPQ:features_casscf
LCPQ:gh-pages
LCPQ:v2.2.2
LCPQ:v2.1.1
LCPQ:v0.10-kpts
LCPQ:v0.9-kpts
LCPQ:v0.8-kpts
LCPQ:v0.7-kpts
LCPQ:v0.6-kpts
LCPQ:v0.5-kpts
LCPQ:v0.4-kpts
LCPQ:v0.3-kpts
LCPQ:v0.2-kpts
LCPQ:v0.1-kpts
LCPQ:v0.0-kpts
LCPQ:2.1.2
LCPQ:2.1.1
LCPQ:2.1.0
LCPQ:2.0.0
LCPQ:v2.0.0-beta
...
compare: LCPQ:919662ee0b64abb6a20a3e61c1d1bb261fcb05c4
Branches Tags
LCPQ:dev-stable
LCPQ:master
LCPQ:torus
LCPQ:dev-pbc
LCPQ:dev-spher_harm
LCPQ:macos
LCPQ:dev-stable-tc-scf
LCPQ:dev-stable-rdm
LCPQ:bugfix
LCPQ:dev-stable-pt-charges
LCPQ:dev-broken
LCPQ:good-dev-tc
LCPQ:guix
LCPQ:dev-tc
LCPQ:cleaning_dft
LCPQ:trexio
LCPQ:csf
LCPQ:v1j4y-patch-2
LCPQ:TApplencourt-patch-1
LCPQ:kpts-patch-1
LCPQ:cleaning_kpts
LCPQ:features_kpts
LCPQ:kgasperich-patch-2
LCPQ:kgasperich-patch-1
LCPQ:features_periodic
LCPQ:features_spack
LCPQ:daily-test
LCPQ:biblio
LCPQ:features_casscf
LCPQ:gh-pages
LCPQ:v2.2.2
LCPQ:v2.1.1
LCPQ:v0.10-kpts
LCPQ:v0.9-kpts
LCPQ:v0.8-kpts
LCPQ:v0.7-kpts
LCPQ:v0.6-kpts
LCPQ:v0.5-kpts
LCPQ:v0.4-kpts
LCPQ:v0.3-kpts
LCPQ:v0.2-kpts
LCPQ:v0.1-kpts
LCPQ:v0.0-kpts
LCPQ:2.1.2
LCPQ:2.1.1
LCPQ:2.1.0
LCPQ:2.0.0
LCPQ:v2.0.0-beta

15 Commits
55286d7889 ... 919662ee0b

Author SHA1 Message Date
Emmanuel Giner
919662ee0b beginning to rewrite two_rdm 2019-07-04 16:16:57 +02:00
Emmanuel Giner
a599079240 Merge branch 'casscf' into dev-lct 2019-07-04 14:28:34 +02:00
Anthony Scemama
62ef1526a2 OpenMP in bielec construction 2019-07-03 21:48:01 +02:00
Anthony Scemama
721f5a662b OpenMP in 4idx 2019-07-03 21:38:40 +02:00
Anthony Scemama
1018c686a9 dgemm 2019-07-03 20:34:09 +02:00
Anthony Scemama
21dc0f5380 dgemm 2019-07-03 08:58:30 +02:00
Anthony Scemama
0c2bf90cc5 DGEMM in 4-idx natorb 2019-07-03 01:08:48 +02:00
Anthony Scemama
05df77ddb8 Fixed previous commit 2019-07-02 23:30:36 +02:00
Anthony Scemama
1db247b27e n_core -> n_core_inactive 2019-07-02 22:52:47 +02:00
Anthony Scemama
e69b2d6b25 Cleaning in bitmasks 2019-07-02 13:13:40 +02:00
Anthony Scemama
e42a4d8fc5 Minor changes 2019-07-01 17:20:09 +02:00
Anthony Scemama
cfaa8be875 Merge branch 'casscf' of github.com:QuantumPackage/qp2 into casscf 2019-07-01 16:31:54 +02:00
Anthony Scemama
d9b9190c06 Merge branch 'dev' into casscf 2019-07-01 12:15:23 +02:00
Anthony Scemama
4f7eefccfd Merge branch 'dev' of github.com:QuantumPackage/qp2 into dev 2019-07-01 12:15:04 +02:00
Anthony Scemama
2794b889d5 Fixed travis 2019-07-01 12:14:52 +02:00
25 changed files with 2579 additions and 1021 deletions
Show Stats Expand all files Collapse all files

2
INSTALL.rst
View File

@ -143,7 +143,7 @@ IRPF90
to Parameters (IRP) method. to Parameters (IRP) method.
* Download the latest version of IRPF90 * Download the latest version of IRPF90
here : `<https://github.com/scemama/irpf90/releases/latest>`_ and move here : `<https://gitlab.com/scemama/irpf90/-/archive/v1.7.2/irpf90-v1.7.2.tar.gz>`_ and move
the downloaded archive in the :file:`${QP_ROOT}/external` directory the downloaded archive in the :file:`${QP_ROOT}/external` directory
* Extract the archive and go into the :file:`irpf90-*` directory to run * Extract the archive and go into the :file:`irpf90-*` directory to run

6
configure vendored
View File

@ -297,12 +297,13 @@ EOF
${QP_ROOT}/bin ${QP_ROOT}/bin
EOF EOF
rm ${QP_ROOT}/external/opam_installer.sh rm ${QP_ROOT}/external/opam_installer.sh
source ${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true source ${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true
${QP_ROOT}/bin/opam init --verbose --yes ${QP_ROOT}/bin/opam init --verbose --yes --comp=4.07.1 --disable-sandboxing
eval $(${QP_ROOT}/bin/opam env) eval $(${QP_ROOT}/bin/opam env)
opam install -y ${OCAML_PACKAGES} || exit 1 opam install -y ${OCAML_PACKAGES} || exit 1
@ -310,13 +311,14 @@ EOF
# Conventional commands # Conventional commands
execute << EOF execute << EOF
chmod +x "\${QP_ROOT}"/external/opam_installer.sh chmod +x "\${QP_ROOT}"/external/opam_installer.sh
"\${QP_ROOT}"/external/opam_installer.sh --no-backup
rm --force \${QP_ROOT}/bin/opam rm --force \${QP_ROOT}/bin/opam
export OPAMROOT=\${OPAMROOT:-\${QP_ROOT}/external/opam} export OPAMROOT=\${OPAMROOT:-\${QP_ROOT}/external/opam}
echo \${QP_ROOT}/bin \ echo \${QP_ROOT}/bin \
| sh \${QP_ROOT}/external/opam_installer.sh | sh \${QP_ROOT}/external/opam_installer.sh
rm \${QP_ROOT}/external/opam_installer.sh rm \${QP_ROOT}/external/opam_installer.sh
source \${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true source \${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true
\${QP_ROOT}/bin/opam init --verbose --yes \${QP_ROOT}/bin/opam init --verbose --yes --comp=4.07.1 --disable-sandboxing
eval \$(\${QP_ROOT}/bin/opam env) eval \$(\${QP_ROOT}/bin/opam env)
opam install -y \${OCAML_PACKAGES} || exit 1 opam install -y \${OCAML_PACKAGES} || exit 1
EOF EOF

817
src/bitmask/bitmasks.irp.f
View File

@ -11,7 +11,7 @@ BEGIN_PROVIDER [ integer, N_int ]
if (N_int > N_int_max) then if (N_int > N_int_max) then
stop 'N_int > N_int_max' stop 'N_int > N_int_max'
endif endif
END_PROVIDER END_PROVIDER
@ -20,7 +20,7 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int) ]
BEGIN_DOC BEGIN_DOC
! Bitmask to include all possible MOs ! Bitmask to include all possible MOs
END_DOC END_DOC
integer :: i,j,k integer :: i,j,k
k=0 k=0
do j=1,N_int do j=1,N_int
@ -37,34 +37,34 @@ END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ] BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ]
implicit none implicit none
integer :: i integer :: i
do i=1,N_int do i=1,N_int
full_ijkl_bitmask_4(i,1) = full_ijkl_bitmask(i) full_ijkl_bitmask_4(i,1) = full_ijkl_bitmask(i)
full_ijkl_bitmask_4(i,2) = full_ijkl_bitmask(i) full_ijkl_bitmask_4(i,2) = full_ijkl_bitmask(i)
full_ijkl_bitmask_4(i,3) = full_ijkl_bitmask(i) full_ijkl_bitmask_4(i,3) = full_ijkl_bitmask(i)
full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i) full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i)
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ] BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ]
implicit none implicit none
integer :: i integer :: i
do i=1,N_int do i=1,N_int
core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1) core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1)
core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1) core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1)
core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1) core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1)
core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1) core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1)
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ] BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ]
implicit none implicit none
integer :: i integer :: i
do i=1,N_int do i=1,N_int
virt_bitmask_4(i,1) = virt_bitmask(i,1) virt_bitmask_4(i,1) = virt_bitmask(i,1)
virt_bitmask_4(i,2) = virt_bitmask(i,1) virt_bitmask_4(i,2) = virt_bitmask(i,1)
virt_bitmask_4(i,3) = virt_bitmask(i,1) virt_bitmask_4(i,3) = virt_bitmask(i,1)
virt_bitmask_4(i,4) = virt_bitmask(i,1) virt_bitmask_4(i,4) = virt_bitmask(i,1)
enddo enddo
END_PROVIDER END_PROVIDER
@ -78,491 +78,480 @@ BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)]
END_DOC END_DOC
integer :: i,j,n integer :: i,j,n
integer :: occ(elec_alpha_num) integer :: occ(elec_alpha_num)
HF_bitmask = 0_bit_kind HF_bitmask = 0_bit_kind
do i=1,elec_alpha_num do i=1,elec_alpha_num
occ(i) = i occ(i) = i
enddo enddo
call list_to_bitstring( HF_bitmask(1,1), occ, elec_alpha_num, N_int) call list_to_bitstring( HF_bitmask(1,1), occ, elec_alpha_num, N_int)
! elec_alpha_num <= elec_beta_num, so occ is already OK. ! elec_alpha_num <= elec_beta_num, so occ is already OK.
call list_to_bitstring( HF_bitmask(1,2), occ, elec_beta_num, N_int) call list_to_bitstring( HF_bitmask(1,2), occ, elec_beta_num, N_int)
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask, (N_int,2)] BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask, (N_int,2)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask ! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask
END_DOC END_DOC
ref_bitmask = HF_bitmask ref_bitmask = HF_bitmask
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, N_generators_bitmask ] BEGIN_PROVIDER [ integer, N_generators_bitmask ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Number of bitmasks for generators ! Number of bitmasks for generators
END_DOC END_DOC
logical :: exists logical :: exists
PROVIDE ezfio_filename N_int PROVIDE ezfio_filename N_int
if (mpi_master) then if (mpi_master) then
call ezfio_has_bitmasks_N_mask_gen(exists) call ezfio_has_bitmasks_N_mask_gen(exists)
if (exists) then if (exists) then
call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask) call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask)
integer :: N_int_check integer :: N_int_check
integer :: bit_kind_check integer :: bit_kind_check
call ezfio_get_bitmasks_bit_kind(bit_kind_check) call ezfio_get_bitmasks_bit_kind(bit_kind_check)
if (bit_kind_check /= bit_kind) then if (bit_kind_check /= bit_kind) then
print *, bit_kind_check, bit_kind print *, bit_kind_check, bit_kind
print *, 'Error: bit_kind is not correct in EZFIO file' print *, 'Error: bit_kind is not correct in EZFIO file'
endif
call ezfio_get_bitmasks_N_int(N_int_check)
if (N_int_check /= N_int) then
print *, N_int_check, N_int
print *, 'Error: N_int is not correct in EZFIO file'
endif
else
N_generators_bitmask = 1
endif endif
call ezfio_get_bitmasks_N_int(N_int_check) ASSERT (N_generators_bitmask > 0)
if (N_int_check /= N_int) then call write_int(6,N_generators_bitmask,'N_generators_bitmask')
print *, N_int_check, N_int
print *, 'Error: N_int is not correct in EZFIO file'
endif
else
N_generators_bitmask = 1
endif endif
ASSERT (N_generators_bitmask > 0)
call write_int(6,N_generators_bitmask,'N_generators_bitmask')
endif
IRP_IF MPI_DEBUG IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr) call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( N_generators_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( N_generators_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read N_generators_bitmask with MPI' stop 'Unable to read N_generators_bitmask with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, N_generators_bitmask_restart ] BEGIN_PROVIDER [ integer, N_generators_bitmask_restart ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Number of bitmasks for generators ! Number of bitmasks for generators
END_DOC END_DOC
logical :: exists logical :: exists
PROVIDE ezfio_filename N_int PROVIDE ezfio_filename N_int
if (mpi_master) then if (mpi_master) then
call ezfio_has_bitmasks_N_mask_gen(exists) call ezfio_has_bitmasks_N_mask_gen(exists)
if (exists) then if (exists) then
call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask_restart) call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask_restart)
integer :: N_int_check integer :: N_int_check
integer :: bit_kind_check integer :: bit_kind_check
call ezfio_get_bitmasks_bit_kind(bit_kind_check) call ezfio_get_bitmasks_bit_kind(bit_kind_check)
if (bit_kind_check /= bit_kind) then if (bit_kind_check /= bit_kind) then
print *, bit_kind_check, bit_kind print *, bit_kind_check, bit_kind
print *, 'Error: bit_kind is not correct in EZFIO file' print *, 'Error: bit_kind is not correct in EZFIO file'
endif
call ezfio_get_bitmasks_N_int(N_int_check)
if (N_int_check /= N_int) then
print *, N_int_check, N_int
print *, 'Error: N_int is not correct in EZFIO file'
endif
else
N_generators_bitmask_restart = 1
endif endif
call ezfio_get_bitmasks_N_int(N_int_check) ASSERT (N_generators_bitmask_restart > 0)
if (N_int_check /= N_int) then call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart')
print *, N_int_check, N_int
print *, 'Error: N_int is not correct in EZFIO file'
endif
else
N_generators_bitmask_restart = 1
endif endif
ASSERT (N_generators_bitmask_restart > 0)
call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart')
endif
IRP_IF MPI_DEBUG IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr) call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( N_generators_bitmask_restart, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( N_generators_bitmask_restart, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read N_generators_bitmask_restart with MPI' stop 'Unable to read N_generators_bitmask_restart with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_generators_bitmask_restart) ] BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_generators_bitmask_restart) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Bitmasks for generator determinants. ! Bitmasks for generator determinants.
! (N_int, alpha/beta, hole/particle, generator). ! (N_int, alpha/beta, hole/particle, generator).
! !
! 3rd index is : ! 3rd index is :
! !
! * 1 : hole for single exc ! * 1 : hole for single exc
! !
! * 2 : particle for single exc ! * 2 : particle for single exc
! !
! * 3 : hole for 1st exc of double ! * 3 : hole for 1st exc of double
! !
! * 4 : particle for 1st exc of double ! * 4 : particle for 1st exc of double
! !
! * 5 : hole for 2nd exc of double ! * 5 : hole for 2nd exc of double
! !
! * 6 : particle for 2nd exc of double ! * 6 : particle for 2nd exc of double
! !
END_DOC END_DOC
logical :: exists logical :: exists
PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask N_int PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask N_int
PROVIDE generators_bitmask_restart PROVIDE generators_bitmask_restart
if (mpi_master) then if (mpi_master) then
call ezfio_has_bitmasks_generators(exists) call ezfio_has_bitmasks_generators(exists)
if (exists) then if (exists) then
call ezfio_get_bitmasks_generators(generators_bitmask_restart) call ezfio_get_bitmasks_generators(generators_bitmask_restart)
else else
integer :: k, ispin integer :: k, ispin
do k=1,N_generators_bitmask
do ispin=1,2
do i=1,N_int
generators_bitmask_restart(i,ispin,s_hole ,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,s_part ,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_hole1,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_part1,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_hole2,k) = full_ijkl_bitmask(i)
generators_bitmask_restart(i,ispin,d_part2,k) = full_ijkl_bitmask(i)
enddo
enddo
enddo
endif
integer :: i
do k=1,N_generators_bitmask do k=1,N_generators_bitmask
do ispin=1,2 do ispin=1,2
do i=1,N_int do i=1,N_int
generators_bitmask_restart(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_hole,k) )
generators_bitmask_restart(i,ispin,s_part ,k) = full_ijkl_bitmask(i) generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_part,k) )
generators_bitmask_restart(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole1,k) )
generators_bitmask_restart(i,ispin,d_part1,k) = full_ijkl_bitmask(i) generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part1,k) )
generators_bitmask_restart(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole2,k) )
generators_bitmask_restart(i,ispin,d_part2,k) = full_ijkl_bitmask(i) generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part2,k) )
enddo enddo
enddo enddo
enddo enddo
endif endif
integer :: i
do k=1,N_generators_bitmask
do ispin=1,2
do i=1,N_int
generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_hole,k) )
generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_part,k) )
generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole1,k) )
generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part1,k) )
generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole2,k) )
generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part2,k) )
enddo
enddo
enddo
endif
IRP_IF MPI_DEBUG IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr) call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( generators_bitmask_restart, N_int*2*6*N_generators_bitmask_restart, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( generators_bitmask_restart, N_int*2*6*N_generators_bitmask_restart, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read generators_bitmask_restart with MPI' stop 'Unable to read generators_bitmask_restart with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_bitmask) ] BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_bitmask) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Bitmasks for generator determinants. ! Bitmasks for generator determinants.
! (N_int, alpha/beta, hole/particle, generator). ! (N_int, alpha/beta, hole/particle, generator).
! !
! 3rd index is : ! 3rd index is :
! !
! * 1 : hole for single exc ! * 1 : hole for single exc
! !
! * 2 : particle for single exc ! * 2 : particle for single exc
! !
! * 3 : hole for 1st exc of double ! * 3 : hole for 1st exc of double
! !
! * 4 : particle for 1st exc of double ! * 4 : particle for 1st exc of double
! !
! * 5 : hole for 2nd exc of double ! * 5 : hole for 2nd exc of double
! !
! * 6 : particle for 2nd exc of double ! * 6 : particle for 2nd exc of double
! !
END_DOC END_DOC
logical :: exists logical :: exists
PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask
if (mpi_master) then if (mpi_master) then
call ezfio_has_bitmasks_generators(exists) call ezfio_has_bitmasks_generators(exists)
if (exists) then if (exists) then
call ezfio_get_bitmasks_generators(generators_bitmask) call ezfio_get_bitmasks_generators(generators_bitmask)
else else
integer :: k, ispin, i integer :: k, ispin, i
do k=1,N_generators_bitmask do k=1,N_generators_bitmask
do ispin=1,2 do ispin=1,2
do i=1,N_int do i=1,N_int
generators_bitmask(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) generators_bitmask(i,ispin,s_hole ,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,s_part ,k) = full_ijkl_bitmask(i) generators_bitmask(i,ispin,s_part ,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) generators_bitmask(i,ispin,d_hole1,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_part1,k) = full_ijkl_bitmask(i) generators_bitmask(i,ispin,d_part1,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) generators_bitmask(i,ispin,d_hole2,k) = full_ijkl_bitmask(i)
generators_bitmask(i,ispin,d_part2,k) = full_ijkl_bitmask(i) generators_bitmask(i,ispin,d_part2,k) = full_ijkl_bitmask(i)
enddo
enddo
enddo enddo
enddo endif
enddo
endif do k=1,N_generators_bitmask
do ispin=1,2
do k=1,N_generators_bitmask do i=1,N_int
do ispin=1,2 generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,k) )
do i=1,N_int generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_part,k) )
generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,k) ) generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,k) )
generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_part,k) ) generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part1,k) )
generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,k) ) generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) )
generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part1,k) ) generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) )
generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) ) enddo
generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) ) enddo
enddo enddo
enddo endif
enddo
endif
IRP_IF MPI_DEBUG IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr) call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( generators_bitmask, N_int*2*6*N_generators_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( generators_bitmask, N_int*2*6*N_generators_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read generators_bitmask with MPI' stop 'Unable to read generators_bitmask with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, N_cas_bitmask ] BEGIN_PROVIDER [ integer, N_cas_bitmask ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Number of bitmasks for CAS ! Number of bitmasks for CAS
END_DOC END_DOC
logical :: exists logical :: exists
PROVIDE ezfio_filename PROVIDE ezfio_filename
PROVIDE N_cas_bitmask N_int PROVIDE N_cas_bitmask N_int
if (mpi_master) then if (mpi_master) then
call ezfio_has_bitmasks_N_mask_cas(exists) call ezfio_has_bitmasks_N_mask_cas(exists)
if (exists) then if (exists) then
call ezfio_get_bitmasks_N_mask_cas(N_cas_bitmask) call ezfio_get_bitmasks_N_mask_cas(N_cas_bitmask)
integer :: N_int_check integer :: N_int_check
integer :: bit_kind_check integer :: bit_kind_check
call ezfio_get_bitmasks_bit_kind(bit_kind_check) call ezfio_get_bitmasks_bit_kind(bit_kind_check)
if (bit_kind_check /= bit_kind) then if (bit_kind_check /= bit_kind) then
print *, bit_kind_check, bit_kind print *, bit_kind_check, bit_kind
print *, 'Error: bit_kind is not correct in EZFIO file' print *, 'Error: bit_kind is not correct in EZFIO file'
endif
call ezfio_get_bitmasks_N_int(N_int_check)
if (N_int_check /= N_int) then
print *, N_int_check, N_int
print *, 'Error: N_int is not correct in EZFIO file'
endif
else
N_cas_bitmask = 1
endif endif
call ezfio_get_bitmasks_N_int(N_int_check) call write_int(6,N_cas_bitmask,'N_cas_bitmask')
if (N_int_check /= N_int) then
print *, N_int_check, N_int
print *, 'Error: N_int is not correct in EZFIO file'
endif
else
N_cas_bitmask = 1
endif endif
call write_int(6,N_cas_bitmask,'N_cas_bitmask') ASSERT (N_cas_bitmask > 0)
endif
ASSERT (N_cas_bitmask > 0)
IRP_IF MPI_DEBUG IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr) call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( N_cas_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( N_cas_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read N_cas_bitmask with MPI' stop 'Unable to read N_cas_bitmask with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ] BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Bitmasks for CAS reference determinants. (N_int, alpha/beta, CAS reference) ! Bitmasks for CAS reference determinants. (N_int, alpha/beta, CAS reference)
END_DOC END_DOC
logical :: exists logical :: exists
integer :: i,i_part,i_gen,j,k integer :: i,i_part,i_gen,j,k
PROVIDE ezfio_filename generators_bitmask_restart full_ijkl_bitmask PROVIDE ezfio_filename generators_bitmask_restart full_ijkl_bitmask
PROVIDE n_generators_bitmask HF_bitmask PROVIDE n_generators_bitmask HF_bitmask
if (mpi_master) then if (mpi_master) then
call ezfio_has_bitmasks_cas(exists) call ezfio_has_bitmasks_cas(exists)
if (exists) then if (exists) then
call ezfio_get_bitmasks_cas(cas_bitmask) call ezfio_get_bitmasks_cas(cas_bitmask)
else
if(N_generators_bitmask == 1)then
do j=1, N_cas_bitmask
do i=1, N_int
cas_bitmask(i,1,j) = iand(not(HF_bitmask(i,1)),full_ijkl_bitmask(i))
cas_bitmask(i,2,j) = iand(not(HF_bitmask(i,2)),full_ijkl_bitmask(i))
enddo
enddo
else else
i_part = 2 if(N_generators_bitmask == 1)then
i_gen = 1 do j=1, N_cas_bitmask
do j=1, N_cas_bitmask do i=1, N_int
do i=1, N_int cas_bitmask(i,1,j) = iand(not(HF_bitmask(i,1)),full_ijkl_bitmask(i))
cas_bitmask(i,1,j) = generators_bitmask_restart(i,1,i_part,i_gen) cas_bitmask(i,2,j) = iand(not(HF_bitmask(i,2)),full_ijkl_bitmask(i))
cas_bitmask(i,2,j) = generators_bitmask_restart(i,2,i_part,i_gen) enddo
enddo enddo
enddo else
i_part = 2
i_gen = 1
do j=1, N_cas_bitmask
do i=1, N_int
cas_bitmask(i,1,j) = generators_bitmask_restart(i,1,i_part,i_gen)
cas_bitmask(i,2,j) = generators_bitmask_restart(i,2,i_part,i_gen)
enddo
enddo
endif
endif endif
endif do i=1,N_cas_bitmask
do i=1,N_cas_bitmask do j = 1, N_cas_bitmask
do j = 1, N_cas_bitmask do k=1,N_int
do k=1,N_int cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k))
cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k)) enddo
enddo enddo
enddo enddo
enddo write(*,*) 'Read CAS bitmask'
write(*,*) 'Read CAS bitmask' endif
endif
IRP_IF MPI_DEBUG IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr) call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF IRP_ENDIF
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( cas_bitmask, N_int*2*N_cas_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( cas_bitmask, N_int*2*N_cas_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read cas_bitmask with MPI' stop 'Unable to read cas_bitmask with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, n_core_inact_orb ] BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)]
implicit none implicit none
integer :: i BEGIN_DOC
n_core_inact_orb = 0 ! Reunion of the core and inactive and virtual bitmasks
do i = 1, N_int END_DOC
n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1)) integer :: i
enddo do i = 1, N_int
ENd_PROVIDER reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1))
reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2))
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] enddo
implicit none END_PROVIDER
BEGIN_DOC
! Reunion of the core and inactive and virtual bitmasks
END_DOC
integer :: i
do i = 1, N_int
reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1))
reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2))
enddo
END_PROVIDER
BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)] BEGIN_PROVIDER [integer(bit_kind), reunion_of_inact_act_bitmask, (N_int,2)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Reunion of the core, inactive and active bitmasks ! Reunion of the inactive and active bitmasks
END_DOC END_DOC
integer :: i,j integer :: i,j
do i = 1, N_int do i = 1, N_int
reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),act_bitmask(i,1)) reunion_of_inact_act_bitmask(i,1) = ior(inact_bitmask(i,1),act_bitmask(i,1))
reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2)) reunion_of_inact_act_bitmask(i,2) = ior(inact_bitmask(i,2),act_bitmask(i,2))
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)] BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Reunion of the inactive, active and virtual bitmasks ! Reunion of the core, inactive and active bitmasks
END_DOC END_DOC
integer :: i,j integer :: i,j
do i = 1, N_int
reunion_of_bitmask(i,1) = ior(ior(cas_bitmask(i,1,1),inact_bitmask(i,1)),virt_bitmask(i,1)) do i = 1, N_int
reunion_of_bitmask(i,2) = ior(ior(cas_bitmask(i,2,1),inact_bitmask(i,2)),virt_bitmask(i,2)) reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),act_bitmask(i,1))
enddo reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2))
END_PROVIDER enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)]
implicit none
BEGIN_DOC
! Reunion of the inactive, active and virtual bitmasks
END_DOC
integer :: i,j
do i = 1, N_int
reunion_of_bitmask(i,1) = ior(ior(cas_bitmask(i,1,1),inact_bitmask(i,1)),virt_bitmask(i,1))
reunion_of_bitmask(i,2) = ior(ior(cas_bitmask(i,2,1),inact_bitmask(i,2)),virt_bitmask(i,2))
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)] BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)]
&BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask, (N_int,2)] &BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask, (N_int,2)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Reunion of the inactive and virtual bitmasks ! Reunion of the inactive and virtual bitmasks
END_DOC END_DOC
integer :: i,j integer :: i,j
do i = 1, N_int do i = 1, N_int
inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1)) inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1))
inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2)) inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2))
core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1)) core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1))
core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2)) core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2))
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, i_bitmask_gen ] BEGIN_PROVIDER [ integer, i_bitmask_gen ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Current bitmask for the generators ! Current bitmask for the generators
END_DOC END_DOC
i_bitmask_gen = 1 i_bitmask_gen = 1
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)] BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask ! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask
END_DOC END_DOC
integer :: i integer :: i
unpaired_alpha_electrons = 0_bit_kind unpaired_alpha_electrons = 0_bit_kind
do i = 1, N_int do i = 1, N_int
unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2)) unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2))
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)]
implicit none implicit none
integer :: i,j integer :: i,j
do i = 1, N_int do i = 1, N_int
closed_shell_ref_bitmask(i,1) = ior(ref_bitmask(i,1),cas_bitmask(i,1,1)) closed_shell_ref_bitmask(i,1) = ior(ref_bitmask(i,1),cas_bitmask(i,1,1))
closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1)) closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1))
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_bitmask, (N_int,2)] BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_bitmask, (N_int,2)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Reunion of the inactive, active and virtual bitmasks ! Reunion of the inactive, active and virtual bitmasks
END_DOC END_DOC
integer :: i,j integer :: i,j
do i = 1, N_int do i = 1, N_int
reunion_of_cas_inact_bitmask(i,1) = ior(act_bitmask(i,1),inact_bitmask(i,1)) reunion_of_cas_inact_bitmask(i,1) = ior(act_bitmask(i,1),inact_bitmask(i,1))
reunion_of_cas_inact_bitmask(i,2) = ior(act_bitmask(i,2),inact_bitmask(i,2)) reunion_of_cas_inact_bitmask(i,2) = ior(act_bitmask(i,2),inact_bitmask(i,2))
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [integer, n_core_orb_allocate]
implicit none
n_core_orb_allocate = max(n_core_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, n_inact_orb_allocate]
implicit none
n_inact_orb_allocate = max(n_inact_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, n_virt_orb_allocate]
implicit none
n_virt_orb_allocate = max(n_virt_orb,1)
END_PROVIDER

602
src/bitmask/core_inact_act_virt.irp.f
View File

@ -1,250 +1,382 @@
use bitmasks use bitmasks
BEGIN_PROVIDER [ integer, n_core_orb]
implicit none
BEGIN_DOC
! Number of core MOs
END_DOC
integer :: i
n_core_orb = 0
do i = 1, mo_num
if(mo_class(i) == 'Core')then
n_core_orb += 1
endif
enddo
call write_int(6,n_core_orb, 'Number of core MOs')
END_PROVIDER
BEGIN_PROVIDER [ integer, n_core_orb] BEGIN_PROVIDER [ integer, n_inact_orb ]
&BEGIN_PROVIDER [ integer, n_inact_orb ] implicit none
&BEGIN_PROVIDER [ integer, n_act_orb] BEGIN_DOC
&BEGIN_PROVIDER [ integer, n_virt_orb ] ! Number of inactive MOs
&BEGIN_PROVIDER [ integer, n_del_orb ] END_DOC
implicit none integer :: i
BEGIN_DOC
! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited n_inact_orb = 0
! in post CAS methods do i = 1, mo_num
! n_inact_orb : Number of inactive orbitals if (mo_class(i) == 'Inactive')then
! virt_bitmask : Bitmaks of vritual orbitals which are supposed to be recieve electrons n_inact_orb += 1
! in post CAS methods endif
! n_virt_orb : Number of virtual orbitals enddo
! list_inact : List of the inactive orbitals which are supposed to be doubly excited
! in post CAS methods call write_int(6,n_inact_orb,'Number of inactive MOs')
! list_virt : List of vritual orbitals which are supposed to be recieve electrons
! in post CAS methods END_PROVIDER
! list_inact_reverse : reverse list of inactive orbitals
! list_inact_reverse(i) = 0 ::> not an inactive
! list_inact_reverse(i) = k ::> IS the kth inactive
! list_virt_reverse : reverse list of virtual orbitals
! list_virt_reverse(i) = 0 ::> not an virtual
! list_virt_reverse(i) = k ::> IS the kth virtual
! list_act(i) = index of the ith active orbital
!
! list_act_reverse : reverse list of active orbitals
! list_act_reverse(i) = 0 ::> not an active
! list_act_reverse(i) = k ::> IS the kth active orbital
END_DOC
logical :: exists
integer :: j,i
n_core_orb = 0 BEGIN_PROVIDER [ integer, n_act_orb]
n_inact_orb = 0 implicit none
n_act_orb = 0 BEGIN_DOC
n_virt_orb = 0 ! Number of active MOs
n_del_orb = 0 END_DOC
do i = 1, mo_num integer :: i
if(mo_class(i) == 'Core')then
n_core_orb += 1 n_act_orb = 0
else if (mo_class(i) == 'Inactive')then do i = 1, mo_num
n_inact_orb += 1 if (mo_class(i) == 'Active')then
else if (mo_class(i) == 'Active')then n_act_orb += 1
n_act_orb += 1 endif
else if (mo_class(i) == 'Virtual')then enddo
n_virt_orb += 1
else if (mo_class(i) == 'Deleted')then call write_int(6,n_act_orb, 'Number of active MOs')
n_del_orb += 1
endif END_PROVIDER
enddo
BEGIN_PROVIDER [ integer, n_virt_orb ]
implicit none
BEGIN_DOC
! Number of virtual MOs
END_DOC
integer :: i
n_virt_orb = 0
do i = 1, mo_num
if (mo_class(i) == 'Virtual')then
n_virt_orb += 1
endif
enddo
call write_int(6,n_virt_orb, 'Number of virtual MOs')
END_PROVIDER
BEGIN_PROVIDER [ integer, n_del_orb ]
implicit none
BEGIN_DOC
! Number of deleted MOs
END_DOC
integer :: i
n_del_orb = 0
do i = 1, mo_num
if (mo_class(i) == 'Deleted')then
n_del_orb += 1
endif
enddo
call write_int(6,n_del_orb, 'Number of deleted MOs')
END_PROVIDER
call write_int(6,n_core_orb, 'Number of core MOs') BEGIN_PROVIDER [ integer, n_core_inact_orb ]
call write_int(6,n_inact_orb,'Number of inactive MOs') implicit none
call write_int(6,n_act_orb, 'Number of active MOs') BEGIN_DOC
call write_int(6,n_virt_orb, 'Number of virtual MOs') ! n_core + n_inact
call write_int(6,n_del_orb, 'Number of deleted MOs') END_DOC
integer :: i
END_PROVIDER n_core_inact_orb = 0
do i = 1, N_int
n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1))
BEGIN_PROVIDER [integer, dim_list_core_orb] enddo
&BEGIN_PROVIDER [integer, dim_list_inact_orb] END_PROVIDER
&BEGIN_PROVIDER [integer, dim_list_virt_orb]
&BEGIN_PROVIDER [integer, dim_list_act_orb]
&BEGIN_PROVIDER [integer, dim_list_del_orb]
implicit none
BEGIN_DOC
! dimensions for the allocation of list_inact, list_virt, list_core and list_act
! it is at least 1
END_DOC
dim_list_core_orb = max(n_core_orb,1)
dim_list_inact_orb = max(n_inact_orb,1)
dim_list_virt_orb = max(n_virt_orb,1)
dim_list_act_orb = max(n_act_orb,1)
dim_list_del_orb = max(n_del_orb,1)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_inact, (dim_list_inact_orb)]
&BEGIN_PROVIDER [ integer, list_virt, (dim_list_virt_orb)]
&BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_num)]
&BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_num)]
&BEGIN_PROVIDER [ integer, list_del_reverse, (mo_num)]
&BEGIN_PROVIDER [ integer, list_del, (mo_num)]
&BEGIN_PROVIDER [integer, list_core, (dim_list_core_orb)]
&BEGIN_PROVIDER [integer, list_core_reverse, (mo_num)]
&BEGIN_PROVIDER [integer, list_act, (dim_list_act_orb)]
&BEGIN_PROVIDER [integer, list_act_reverse, (mo_num)]
&BEGIN_PROVIDER [ integer(bit_kind), core_bitmask, (N_int,2)]
&BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask, (N_int,2) ]
&BEGIN_PROVIDER [ integer(bit_kind), act_bitmask, (N_int,2) ]
&BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask, (N_int,2) ]
&BEGIN_PROVIDER [ integer(bit_kind), del_bitmask, (N_int,2) ]
implicit none
BEGIN_DOC
! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited
! in post CAS methods
! n_inact_orb : Number of inactive orbitals
! virt_bitmask : Bitmaks of vritual orbitals which are supposed to be recieve electrons
! in post CAS methods
! n_virt_orb : Number of virtual orbitals
! list_inact : List of the inactive orbitals which are supposed to be doubly excited
! in post CAS methods
! list_virt : List of vritual orbitals which are supposed to be recieve electrons
! in post CAS methods
! list_inact_reverse : reverse list of inactive orbitals
! list_inact_reverse(i) = 0 ::> not an inactive
! list_inact_reverse(i) = k ::> IS the kth inactive
! list_virt_reverse : reverse list of virtual orbitals
! list_virt_reverse(i) = 0 ::> not an virtual
! list_virt_reverse(i) = k ::> IS the kth virtual
! list_act(i) = index of the ith active orbital
!
! list_act_reverse : reverse list of active orbitals
! list_act_reverse(i) = 0 ::> not an active
! list_act_reverse(i) = k ::> IS the kth active orbital
END_DOC
logical :: exists
integer :: j,i
integer :: n_core_orb_tmp, n_inact_orb_tmp, n_act_orb_tmp, n_virt_orb_tmp,n_del_orb_tmp
integer :: list_core_tmp(N_int*bit_kind_size)
integer :: list_inact_tmp(N_int*bit_kind_size)
integer :: list_act_tmp(N_int*bit_kind_size)
integer :: list_virt_tmp(N_int*bit_kind_size)
integer :: list_del_tmp(N_int*bit_kind_size)
list_core = 0
list_inact = 0
list_act = 0
list_virt = 0
list_del = 0
list_core_reverse = 0
list_inact_reverse = 0
list_act_reverse = 0
list_virt_reverse = 0
list_del_reverse = 0
n_core_orb_tmp = 0
n_inact_orb_tmp = 0
n_act_orb_tmp = 0
n_virt_orb_tmp = 0
n_del_orb_tmp = 0
core_bitmask = 0_bit_kind
inact_bitmask = 0_bit_kind
act_bitmask = 0_bit_kind
virt_bitmask = 0_bit_kind
do i = 1, mo_num
if(mo_class(i) == 'Core')then
n_core_orb_tmp += 1
list_core(n_core_orb_tmp) = i
list_core_tmp(n_core_orb_tmp) = i
list_core_reverse(i) = n_core_orb_tmp
else if (mo_class(i) == 'Inactive')then
n_inact_orb_tmp += 1
list_inact(n_inact_orb_tmp) = i
list_inact_tmp(n_inact_orb_tmp) = i
list_inact_reverse(i) = n_inact_orb_tmp
else if (mo_class(i) == 'Active')then
n_act_orb_tmp += 1
list_act(n_act_orb_tmp) = i
list_act_tmp(n_act_orb_tmp) = i
list_act_reverse(i) = n_act_orb_tmp
else if (mo_class(i) == 'Virtual')then
n_virt_orb_tmp += 1
list_virt(n_virt_orb_tmp) = i
list_virt_tmp(n_virt_orb_tmp) = i
list_virt_reverse(i) = n_virt_orb_tmp
else if (mo_class(i) == 'Deleted')then
n_del_orb_tmp += 1
list_del(n_del_orb_tmp) = i
list_del_tmp(n_del_orb_tmp) = i
list_del_reverse(i) = n_del_orb_tmp
endif
enddo
if(n_core_orb.ne.0)then
call list_to_bitstring( core_bitmask(1,1), list_core, n_core_orb, N_int)
call list_to_bitstring( core_bitmask(1,2), list_core, n_core_orb, N_int)
endif
if(n_inact_orb.ne.0)then
call list_to_bitstring( inact_bitmask(1,1), list_inact, n_inact_orb, N_int)
call list_to_bitstring( inact_bitmask(1,2), list_inact, n_inact_orb, N_int)
endif
if(n_act_orb.ne.0)then
call list_to_bitstring( act_bitmask(1,1), list_act, n_act_orb, N_int)
call list_to_bitstring( act_bitmask(1,2), list_act, n_act_orb, N_int)
endif
if(n_virt_orb.ne.0)then
call list_to_bitstring( virt_bitmask(1,1), list_virt, n_virt_orb, N_int)
call list_to_bitstring( virt_bitmask(1,2), list_virt, n_virt_orb, N_int)
endif
if(n_del_orb.ne.0)then
call list_to_bitstring( del_bitmask(1,1), list_del, n_del_orb, N_int)
call list_to_bitstring( del_bitmask(1,2), list_del, n_del_orb, N_int)
endif
END_PROVIDER
BEGIN_PROVIDER [integer, n_inact_act_orb ] BEGIN_PROVIDER [integer, n_inact_act_orb ]
implicit none implicit none
n_inact_act_orb = (n_inact_orb+n_act_orb) BEGIN_DOC
! n_inact + n_act
END_DOC
n_inact_act_orb = (n_inact_orb+n_act_orb)
END_PROVIDER
BEGIN_PROVIDER [integer, dim_list_core_orb]
implicit none
BEGIN_DOC
! dimensions for the allocation of list_core.
! it is at least 1
END_DOC
dim_list_core_orb = max(n_core_orb,1)
END_PROVIDER
END_PROVIDER BEGIN_PROVIDER [integer, dim_list_inact_orb]
implicit none
BEGIN_DOC
! dimensions for the allocation of list_inact.
! it is at least 1
END_DOC
dim_list_inact_orb = max(n_inact_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, list_inact_act, (n_inact_act_orb)] BEGIN_PROVIDER [integer, dim_list_act_orb]
integer :: i,itmp implicit none
itmp = 0 BEGIN_DOC
do i = 1, n_inact_orb ! dimensions for the allocation of list_act.
itmp += 1 ! it is at least 1
list_inact_act(itmp) = list_inact(i) END_DOC
enddo dim_list_act_orb = max(n_act_orb,1)
do i = 1, n_act_orb END_PROVIDER
itmp += 1
list_inact_act(itmp) = list_act(i) BEGIN_PROVIDER [integer, dim_list_virt_orb]
enddo implicit none
END_PROVIDER BEGIN_DOC
! dimensions for the allocation of list_virt.
! it is at least 1
END_DOC
dim_list_virt_orb = max(n_virt_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, dim_list_del_orb]
implicit none
BEGIN_DOC
! dimensions for the allocation of list_del.
! it is at least 1
END_DOC
dim_list_del_orb = max(n_del_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, n_core_inact_act_orb ] BEGIN_PROVIDER [integer, n_core_inact_act_orb ]
implicit none implicit none
n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb) BEGIN_DOC
! Number of core inactive and active MOs
END_DOC
n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb)
END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [integer, list_core_inact_act, (n_core_inact_act_orb)]
&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (n_core_inact_act_orb)] BEGIN_PROVIDER [ integer(bit_kind), core_bitmask , (N_int,2) ]
integer :: i,itmp &BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask, (N_int,2) ]
itmp = 0 &BEGIN_PROVIDER [ integer(bit_kind), act_bitmask , (N_int,2) ]
do i = 1, n_core_orb &BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask , (N_int,2) ]
itmp += 1 &BEGIN_PROVIDER [ integer(bit_kind), del_bitmask , (N_int,2) ]
list_core_inact_act(itmp) = list_core(i) implicit none
enddo BEGIN_DOC
do i = 1, n_inact_orb ! Bitmask identifying the core/inactive/active/virtual/deleted MOs
itmp += 1 END_DOC
list_core_inact_act(itmp) = list_inact(i)
enddo
do i = 1, n_act_orb
itmp += 1
list_core_inact_act(itmp) = list_act(i)
enddo
integer :: occ_inact(N_int*bit_kind_size) core_bitmask = 0_bit_kind
occ_inact = 0 inact_bitmask = 0_bit_kind
call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int) act_bitmask = 0_bit_kind
list_inact_reverse = 0 virt_bitmask = 0_bit_kind
do i = 1, n_core_inact_act_orb del_bitmask = 0_bit_kind
list_core_inact_act_reverse(occ_inact(i)) = i
enddo if(n_core_orb > 0)then
END_PROVIDER call list_to_bitstring( core_bitmask(1,1), list_core, n_core_orb, N_int)
call list_to_bitstring( core_bitmask(1,2), list_core, n_core_orb, N_int)
endif
if(n_inact_orb > 0)then
call list_to_bitstring( inact_bitmask(1,1), list_inact, n_inact_orb, N_int)
call list_to_bitstring( inact_bitmask(1,2), list_inact, n_inact_orb, N_int)
endif
if(n_act_orb > 0)then
call list_to_bitstring( act_bitmask(1,1), list_act, n_act_orb, N_int)
call list_to_bitstring( act_bitmask(1,2), list_act, n_act_orb, N_int)
endif
if(n_virt_orb > 0)then
call list_to_bitstring( virt_bitmask(1,1), list_virt, n_virt_orb, N_int)
call list_to_bitstring( virt_bitmask(1,2), list_virt, n_virt_orb, N_int)
endif
if(n_del_orb > 0)then
call list_to_bitstring( del_bitmask(1,1), list_del, n_del_orb, N_int)
call list_to_bitstring( del_bitmask(1,2), list_del, n_del_orb, N_int)
endif
END_PROVIDER
BEGIN_PROVIDER [ integer, list_core , (dim_list_core_orb) ]
&BEGIN_PROVIDER [ integer, list_core_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of MO indices which are in the core.
END_DOC
integer :: i, n
list_core = 0
list_core_reverse = 0
n=0
do i = 1, mo_num
if(mo_class(i) == 'Core')then
n += 1
list_core(n) = i
list_core_reverse(i) = n
endif
enddo
print *, 'Core MOs:'
print *, list_core(1:n_core_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_inact , (dim_list_inact_orb) ]
&BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of MO indices which are inactive.
END_DOC
integer :: i, n
list_inact = 0
list_inact_reverse = 0
n=0
do i = 1, mo_num
if (mo_class(i) == 'Inactive')then
n += 1
list_inact(n) = i
list_inact_reverse(i) = n
endif
enddo
print *, 'Inactive MOs:'
print *, list_inact(1:n_inact_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_virt , (dim_list_virt_orb) ]
&BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of MO indices which are virtual
END_DOC
integer :: i, n
list_virt = 0
list_virt_reverse = 0
n=0
do i = 1, mo_num
if (mo_class(i) == 'Virtual')then
n += 1
list_virt(n) = i
list_virt_reverse(i) = n
endif
enddo
print *, 'Virtual MOs:'
print *, list_virt(1:n_virt_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_del , (dim_list_del_orb) ]
&BEGIN_PROVIDER [ integer, list_del_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of MO indices which are deleted.
END_DOC
integer :: i, n
list_del = 0
list_del_reverse = 0
n=0
do i = 1, mo_num
if (mo_class(i) == 'Deleted')then
n += 1
list_del(n) = i
list_del_reverse(i) = n
endif
enddo
print *, 'Deleted MOs:'
print *, list_del(1:n_del_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_act , (dim_list_act_orb) ]
&BEGIN_PROVIDER [ integer, list_act_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of MO indices which are in the active.
END_DOC
integer :: i, n
list_act = 0
list_act_reverse = 0
n=0
do i = 1, mo_num
if (mo_class(i) == 'Active')then
n += 1
list_act(n) = i
list_act_reverse(i) = n
endif
enddo
print *, 'Active MOs:'
print *, list_act(1:n_act_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_core_inact , (n_core_inact_orb) ]
&BEGIN_PROVIDER [ integer, list_core_inact_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of indices of the core and inactive MOs
END_DOC
integer :: i,itmp
call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), list_core_inact, itmp, N_int)
list_core_inact_reverse = 0
ASSERT (itmp == n_core_inact_orb)
do i = 1, n_core_inact_orb
list_core_inact_reverse(list_core_inact(i)) = i
enddo
print *, 'Core and Inactive MOs:'
print *, list_core_inact(1:n_core_inact_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_core_inact_act , (n_core_inact_act_orb) ]
&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of indices of the core inactive and active MOs
END_DOC
integer :: i,itmp
call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), list_core_inact_act, itmp, N_int)
list_core_inact_act_reverse = 0
ASSERT (itmp == n_core_inact_act_orb)
do i = 1, n_core_inact_act_orb
list_core_inact_act_reverse(list_core_inact_act(i)) = i
enddo
print *, 'Core, Inactive and Active MOs:'
print *, list_core_inact_act(1:n_core_inact_act_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, list_inact_act , (n_inact_act_orb) ]
&BEGIN_PROVIDER [ integer, list_inact_act_reverse, (mo_num) ]
implicit none
BEGIN_DOC
! List of indices of the inactive and active MOs
END_DOC
integer :: i,itmp
call bitstring_to_list(reunion_of_inact_act_bitmask(1,1), list_inact_act, itmp, N_int)
list_inact_act_reverse = 0
ASSERT (itmp == n_inact_act_orb)
do i = 1, n_inact_act_orb
list_inact_act_reverse(list_inact_act(i)) = i
enddo
print *, 'Inactive and Active MOs:'
print *, list_inact_act(1:n_inact_act_orb)
END_PROVIDER

136
src/casscf/bielec.irp.f
View File

@ -1,65 +1,58 @@
BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)]
BEGIN_DOC BEGIN_DOC
! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active ! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active
! indices are unshifted orbital numbers ! indices are unshifted orbital numbers
END_DOC END_DOC
implicit none implicit none
integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 integer :: i,j,ii,jj,p,q,i3,j3,t3,v3
double precision, allocatable :: integrals_array(:,:)
real*8 :: mo_two_e_integral real*8 :: mo_two_e_integral
allocate(integrals_array(mo_num,mo_num)) bielec_PQxx(:,:,:,:) = 0.d0
PROVIDE mo_two_e_integrals_in_map
bielec_PQxx = 0.d0 !$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,ii,j,jj,i3,j3) &
do i=1,n_core_orb !$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PQxx, &
ii=list_core(i) !$OMP n_act_orb,mo_integrals_map,list_act)
do j=i,n_core_orb
jj=list_core(j) !$OMP DO
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) do i=1,n_core_inact_orb
do p=1,mo_num ii=list_core_inact(i)
do q=1,mo_num do j=i,n_core_inact_orb
bielec_PQxx(p,q,i,j)=integrals_array(p,q) jj=list_core_inact(j)
bielec_PQxx(p,q,j,i)=integrals_array(p,q) call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j),mo_integrals_map)
end do bielec_PQxx(:,:,j,i)=bielec_PQxx(:,:,i,j)
end do
end do end do
do j=1,n_act_orb do j=1,n_act_orb
jj=list_act(j) jj=list_act(j)
j3=j+n_core_orb j3=j+n_core_inact_orb
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j3),mo_integrals_map)
do p=1,mo_num bielec_PQxx(:,:,j3,i)=bielec_PQxx(:,:,i,j3)
do q=1,mo_num
bielec_PQxx(p,q,i,j3)=integrals_array(p,q)
bielec_PQxx(p,q,j3,i)=integrals_array(p,q)
end do
end do
end do end do
end do end do
!$OMP END DO
! (ij|pq) !$OMP DO
do i=1,n_act_orb do i=1,n_act_orb
ii=list_act(i) ii=list_act(i)
i3=i+n_core_orb i3=i+n_core_inact_orb
do j=i,n_act_orb do j=i,n_act_orb
jj=list_act(j) jj=list_act(j)
j3=j+n_core_orb j3=j+n_core_inact_orb
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i3,j3),mo_integrals_map)
do p=1,mo_num bielec_PQxx(:,:,j3,i3)=bielec_PQxx(:,:,i3,j3)
do q=1,mo_num
bielec_PQxx(p,q,i3,j3)=integrals_array(p,q)
bielec_PQxx(p,q,j3,i3)=integrals_array(p,q)
end do
end do
end do end do
end do end do
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb, mo_num)]
BEGIN_DOC BEGIN_DOC
! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active ! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active
! indices are unshifted orbital numbers ! indices are unshifted orbital numbers
@ -69,17 +62,24 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_a
double precision, allocatable :: integrals_array(:,:) double precision, allocatable :: integrals_array(:,:)
real*8 :: mo_two_e_integral real*8 :: mo_two_e_integral
PROVIDE mo_two_e_integrals_in_map
bielec_PxxQ = 0.d0
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,ii,j,jj,i3,j3,integrals_array) &
!$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PxxQ, &
!$OMP n_act_orb,mo_integrals_map,list_act)
allocate(integrals_array(mo_num,mo_num)) allocate(integrals_array(mo_num,mo_num))
bielec_PxxQ = 0.d0 !$OMP DO
do i=1,n_core_inact_orb
do i=1,n_core_orb ii=list_core_inact(i)
ii=list_core(i) do j=i,n_core_inact_orb
do j=i,n_core_orb jj=list_core_inact(j)
jj=list_core(j) call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) do q=1,mo_num
do p=1,mo_num do p=1,mo_num
do q=1,mo_num
bielec_PxxQ(p,i,j,q)=integrals_array(p,q) bielec_PxxQ(p,i,j,q)=integrals_array(p,q)
bielec_PxxQ(p,j,i,q)=integrals_array(q,p) bielec_PxxQ(p,j,i,q)=integrals_array(q,p)
end do end do
@ -87,34 +87,41 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_a
end do end do
do j=1,n_act_orb do j=1,n_act_orb
jj=list_act(j) jj=list_act(j)
j3=j+n_core_orb j3=j+n_core_inact_orb
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num do q=1,mo_num
do q=1,mo_num do p=1,mo_num
bielec_PxxQ(p,i,j3,q)=integrals_array(p,q) bielec_PxxQ(p,i,j3,q)=integrals_array(p,q)
bielec_PxxQ(p,j3,i,q)=integrals_array(q,p) bielec_PxxQ(p,j3,i,q)=integrals_array(q,p)
end do end do
end do end do
end do end do
end do end do
!$OMP END DO
! (ip|qj) ! (ip|qj)
!$OMP DO
do i=1,n_act_orb do i=1,n_act_orb
ii=list_act(i) ii=list_act(i)
i3=i+n_core_orb i3=i+n_core_inact_orb
do j=i,n_act_orb do j=i,n_act_orb
jj=list_act(j) jj=list_act(j)
j3=j+n_core_orb j3=j+n_core_inact_orb
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num do q=1,mo_num
do q=1,mo_num do p=1,mo_num
bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q) bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q)
bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p) bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p)
end do end do
end do end do
end do end do
end do end do
!$OMP END DO
deallocate(integrals_array)
!$OMP END PARALLEL
END_PROVIDER END_PROVIDER
@ -125,24 +132,25 @@ BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)]
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,p,t,u,v integer :: i,j,k,p,t,u,v
double precision, allocatable :: integrals_array(:) double precision, external :: mo_two_e_integral
real*8 :: mo_two_e_integral PROVIDE mo_two_e_integrals_in_map
allocate(integrals_array(mo_num)) !$OMP PARALLEL DO DEFAULT(NONE) &
!$OMP PRIVATE(i,j,k,p,t,u,v) &
do i=1,n_act_orb !$OMP SHARED(mo_num,n_act_orb,list_act,bielecCI)
t=list_act(i) do p=1,mo_num
do j=1,n_act_orb do j=1,n_act_orb
u=list_act(j) u=list_act(j)
do k=1,n_act_orb do k=1,n_act_orb
v=list_act(k) v=list_act(k)
! (tu|vp) do i=1,n_act_orb
call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array,mo_integrals_map) t=list_act(i)
do p=1,mo_num bielecCI(i,k,j,p) = mo_two_e_integral(t,u,v,p)
bielecCI(i,k,j,p)=integrals_array(p)
end do end do
end do end do
end do end do
end do end do
END_PROVIDER !$OMP END PARALLEL DO
END_PROVIDER

433
src/casscf/bielec_natorb.irp.f
View File

@ -1,180 +1,264 @@
BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)]
BEGIN_DOC BEGIN_DOC
! integral (pq|xx) in the basis of natural MOs ! integral (pq|xx) in the basis of natural MOs
! indices are unshifted orbital numbers ! indices are unshifted orbital numbers
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,l,t,u,p,q,pp integer :: i,j,k,l,t,u,p,q,pp
real*8 :: d(n_act_orb) double precision, allocatable :: f(:,:,:), d(:,:,:)
bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:)
do j=1,mo_num
do k=1,n_core_orb+n_act_orb !$OMP PARALLEL DEFAULT(NONE) &
do l=1,n_core_orb+n_act_orb !$OMP PRIVATE(j,k,l,p,pp,d,f) &
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
!$OMP bielec_PQxx_no,bielec_PQxx,list_act,natorbsCI)
allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), &
d(n_act_orb,mo_num,n_core_inact_act_orb))
!$OMP DO
do l=1,n_core_inact_act_orb
bielec_PQxx_no(:,:,:,l) = bielec_PQxx(:,:,:,l)
do k=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb do p=1,n_act_orb
d(p)=0.D0 f(p,j,k)=bielec_PQxx_no(list_act(p),j,k,l)
end do end do
end do
end do
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
natorbsCI, size(natorbsCI,1), &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb do p=1,n_act_orb
pp=n_act_orb-p+1 pp=n_act_orb-p+1
do q=1,n_act_orb bielec_PQxx_no(list_act(p),j,k,l)=d(pp,j,k)
d(pp)+=bielec_PQxx_no(list_act(q),j,k,l)*natorbsCI(q,p)
end do
end do end do
end do
do j=1,mo_num
do p=1,n_act_orb do p=1,n_act_orb
bielec_PQxx_no(list_act(p),j,k,l)=d(p) f(p,j,k)=bielec_PQxx_no(j,list_act(p),k,l)
end do
end do
end do
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
natorbsCI, n_act_orb, &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_core_inact_act_orb
do p=1,n_act_orb
pp=n_act_orb-p+1
do j=1,mo_num
bielec_PQxx_no(j,list_act(p),k,l)=d(pp,j,k)
end do end do
end do end do
end do end do
end do end do
! 2nd quarter !$OMP END DO NOWAIT
do j=1,mo_num
do k=1,n_core_orb+n_act_orb deallocate (f,d)
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb allocate (f(mo_num,mo_num,n_act_orb),d(mo_num,mo_num,n_act_orb))
d(p)=0.D0
!$OMP DO
do l=1,n_core_inact_act_orb
do p=1,n_act_orb
do k=1,mo_num
do j=1,mo_num
f(j,k,p) = bielec_PQxx_no(j,k,n_core_inact_orb+p,l)
end do end do
do p=1,n_act_orb end do
pp=n_act_orb-p+1 end do
do q=1,n_act_orb call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, &
d(pp)+=bielec_PQxx_no(j,list_act(q),k,l)*natorbsCI(q,p) f, mo_num*mo_num, &
end do natorbsCI, n_act_orb, &
end do 0.d0, &
do p=1,n_act_orb d, mo_num*mo_num)
bielec_PQxx_no(j,list_act(p),k,l)=d(p) do p=1,n_act_orb
pp=n_act_orb-p+1
do k=1,mo_num
do j=1,mo_num
bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(j,k,pp)
end do end do
end do end do
end do end do
end do end do
! 3rd quarter !$OMP END DO NOWAIT
do j=1,mo_num
do k=1,mo_num !$OMP BARRIER
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb !$OMP DO
d(p)=0.D0 do l=1,n_core_inact_act_orb
do p=1,n_act_orb
do k=1,mo_num
do j=1,mo_num
f(j,k,p) = bielec_PQxx_no(j,k,l,n_core_inact_orb+p)
end do end do
do p=1,n_act_orb end do
pp=n_act_orb-p+1 end do
do q=1,n_act_orb call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, &
d(pp)+=bielec_PQxx_no(j,k,n_core_orb+q,l)*natorbsCI(q,p) f, mo_num*mo_num, &
end do natorbsCI, n_act_orb, &
end do 0.d0, &
do p=1,n_act_orb d, mo_num*mo_num)
bielec_PQxx_no(j,k,n_core_orb+p,l)=d(p) do p=1,n_act_orb
end do pp=n_act_orb-p+1
end do do k=1,mo_num
end do do j=1,mo_num
end do bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(j,k,pp)
! 4th quarter
do j=1,mo_num
do k=1,mo_num
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PQxx_no(j,k,l,n_core_orb+q)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PQxx_no(j,k,l,n_core_orb+p)=d(p)
end do end do
end do end do
end do end do
end do end do
!$OMP END DO
deallocate (f,d)
!$OMP END PARALLEL
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)]
BEGIN_DOC BEGIN_DOC
! integral (px|xq) in the basis of natural MOs ! integral (px|xq) in the basis of natural MOs
! indices are unshifted orbital numbers ! indices are unshifted orbital numbers
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,l,t,u,p,q,pp integer :: i,j,k,l,t,u,p,q,pp
real*8 :: d(n_act_orb) double precision, allocatable :: f(:,:,:), d(:,:,:)
bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:) !$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(j,k,l,p,pp,d,f) &
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
!$OMP bielec_PxxQ_no,bielec_PxxQ,list_act,natorbsCI)
allocate (f(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb), &
d(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb))
!$OMP DO
do j=1,mo_num do j=1,mo_num
do k=1,n_core_orb+n_act_orb bielec_PxxQ_no(:,:,:,j) = bielec_PxxQ(:,:,:,j)
do l=1,n_core_orb+n_act_orb do l=1,n_core_inact_act_orb
do k=1,n_core_inact_act_orb
do p=1,n_act_orb do p=1,n_act_orb
d(p)=0.D0 f(p,k,l) = bielec_PxxQ_no(list_act(p),k,l,j)
end do end do
end do
end do
call dgemm('T','N',n_act_orb,n_core_inact_act_orb**2,n_act_orb,1.d0, &
natorbsCI, size(natorbsCI,1), &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do l=1,n_core_inact_act_orb
do k=1,n_core_inact_act_orb
do p=1,n_act_orb do p=1,n_act_orb
pp=n_act_orb-p+1 pp=n_act_orb-p+1
do q=1,n_act_orb bielec_PxxQ_no(list_act(p),k,l,j)=d(pp,k,l)
d(pp)+=bielec_PxxQ_no(list_act(q),k,l,j)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PxxQ_no(list_act(p),k,l,j)=d(p)
end do end do
end do end do
end do end do
end do end do
! 2nd quarter !$OMP END DO NOWAIT
do j=1,mo_num
do k=1,n_core_orb+n_act_orb deallocate (f,d)
do l=1,n_core_orb+n_act_orb
allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), &
d(n_act_orb,mo_num,n_core_inact_act_orb))
!$OMP DO
do k=1,mo_num
do l=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb do p=1,n_act_orb
d(p)=0.D0 f(p,j,l) = bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)
end do end do
end do
end do
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
natorbsCI, size(natorbsCI,1), &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do l=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb do p=1,n_act_orb
pp=n_act_orb-p+1 pp=n_act_orb-p+1
do q=1,n_act_orb bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(pp,j,l)
d(pp)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PxxQ_no(j,k,l,list_act(p))=d(p)
end do end do
end do end do
end do end do
end do end do
! 3rd quarter !$OMP END DO NOWAIT
do j=1,mo_num
do k=1,mo_num deallocate(f,d)
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb allocate(f(mo_num,n_core_inact_act_orb,n_act_orb), &
d(p)=0.D0 d(mo_num,n_core_inact_act_orb,n_act_orb) )
!$OMP DO
do k=1,mo_num
do p=1,n_act_orb
do l=1,n_core_inact_act_orb
do j=1,mo_num
f(j,l,p) = bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)
end do end do
do p=1,n_act_orb end do
pp=n_act_orb-p+1 end do
do q=1,n_act_orb call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, &
d(pp)+=bielec_PxxQ_no(j,n_core_orb+q,l,k)*natorbsCI(q,p) f, mo_num*n_core_inact_act_orb, &
end do natorbsCI, size(natorbsCI,1), &
end do 0.d0, &
do p=1,n_act_orb d, mo_num*n_core_inact_act_orb)
bielec_PxxQ_no(j,n_core_orb+p,l,k)=d(p) do p=1,n_act_orb
pp=n_act_orb-p+1
do l=1,n_core_inact_act_orb
do j=1,mo_num
bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(j,l,pp)
end do end do
end do end do
end do end do
end do end do
! 4th quarter !$OMP END DO NOWAIT
do j=1,mo_num
do k=1,mo_num !$OMP BARRIER
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb !$OMP DO
d(p)=0.D0 do l=1,n_core_inact_act_orb
do p=1,n_act_orb
do k=1,n_core_inact_act_orb
do j=1,mo_num
f(j,k,p) = bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)
end do end do
do p=1,n_act_orb end do
pp=n_act_orb-p+1 end do
do q=1,n_act_orb call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, &
d(pp)+=bielec_PxxQ_no(j,l,n_core_orb+q,k)*natorbsCI(q,p) f, mo_num*n_core_inact_act_orb, &
end do natorbsCI, size(natorbsCI,1), &
end do 0.d0, &
do p=1,n_act_orb d, mo_num*n_core_inact_act_orb)
bielec_PxxQ_no(j,l,n_core_orb+p,k)=d(p) do p=1,n_act_orb
pp=n_act_orb-p+1
do k=1,n_core_inact_act_orb
do j=1,mo_num
bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)=d(j,k,pp)
end do end do
end do end do
end do end do
end do end do
!$OMP END DO NOWAIT
deallocate(f,d)
!$OMP END PARALLEL
END_PROVIDER END_PROVIDER
@ -186,85 +270,112 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)]
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,l,t,u,p,q,pp integer :: i,j,k,l,t,u,p,q,pp
real*8 :: d(n_act_orb) double precision, allocatable :: f(:,:,:), d(:,:,:)
bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:) !$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(j,k,l,p,pp,d,f) &
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
!$OMP bielecCI_no,bielecCI,list_act,natorbsCI)
do j=1,n_act_orb allocate (f(n_act_orb,n_act_orb,mo_num), &
d(n_act_orb,n_act_orb,mo_num))
!$OMP DO
do l=1,mo_num
bielecCI_no(:,:,:,l) = bielecCI(:,:,:,l)
do k=1,n_act_orb do k=1,n_act_orb
do l=1,mo_num do j=1,n_act_orb
do p=1,n_act_orb do p=1,n_act_orb
d(p)=0.D0 f(p,j,k)=bielecCI_no(p,j,k,l)
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielecCI_no(p,j,k,l)=d(p)
end do end do
end do end do
end do end do
end do call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, &
! 2nd quarter natorbsCI, size(natorbsCI,1), &
do j=1,n_act_orb f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_act_orb do k=1,n_act_orb
do l=1,mo_num do j=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb do p=1,n_act_orb
pp=n_act_orb-p+1 pp=n_act_orb-p+1
do q=1,n_act_orb bielecCI_no(p,j,k,l)=d(pp,j,k)
d(pp)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p)
end do
end do end do
end do
do j=1,n_act_orb
do p=1,n_act_orb do p=1,n_act_orb
bielecCI_no(j,p,k,l)=d(p) f(p,j,k)=bielecCI_no(j,p,k,l)
end do end do
end do end do
end do end do
end do call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, &
! 3rd quarter natorbsCI, n_act_orb, &
do j=1,n_act_orb f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_act_orb do k=1,n_act_orb
do l=1,mo_num do p=1,n_act_orb
do p=1,n_act_orb pp=n_act_orb-p+1
d(p)=0.D0 do j=1,n_act_orb
bielecCI_no(j,p,k,l)=d(pp,j,k)
end do end do
do p=1,n_act_orb end do
pp=n_act_orb-p+1 end do
do q=1,n_act_orb
d(pp)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p) do p=1,n_act_orb
end do do k=1,n_act_orb
do j=1,n_act_orb
f(j,k,p)=bielecCI_no(j,k,p,l)
end do end do
do p=1,n_act_orb end do
bielecCI_no(j,k,p,l)=d(p) end do
call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, &
f, n_act_orb*n_act_orb, &
natorbsCI, n_act_orb, &
0.d0, &
d, n_act_orb*n_act_orb)
do p=1,n_act_orb
pp=n_act_orb-p+1
do k=1,n_act_orb
do j=1,n_act_orb
bielecCI_no(j,k,p,l)=d(j,k,pp)
end do end do
end do end do
end do end do
end do end do
! 4th quarter !$OMP END DO
do j=1,n_act_orb
do k=1,n_act_orb !$OMP DO
do l=1,n_act_orb do l=1,n_act_orb
do p=1,n_act_orb do p=1,n_act_orb
d(p)=0.D0 do k=1,n_act_orb
do j=1,n_act_orb
f(j,k,p)=bielecCI_no(j,k,l,list_act(p))
end do end do
do p=1,n_act_orb end do
pp=n_act_orb-p+1 end do
do q=1,n_act_orb call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, &
d(pp)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p) f, n_act_orb*n_act_orb, &
end do natorbsCI, n_act_orb, &
end do 0.d0, &
do p=1,n_act_orb d, n_act_orb*n_act_orb)
bielecCI_no(j,k,l,list_act(p))=d(p)
do p=1,n_act_orb
pp=n_act_orb-p+1
do k=1,n_act_orb
do j=1,n_act_orb
bielecCI_no(j,k,l,list_act(p))=d(j,k,pp)
end do end do
end do end do
end do end do
end do end do
!$OMP END DO
deallocate(d,f)
!$OMP END PARALLEL
END_PROVIDER END_PROVIDER

19
src/casscf/get_energy.irp.f
View File

@ -33,4 +33,23 @@ subroutine routine
enddo enddo
enddo enddo
print*,'accu = ',accu(1) print*,'accu = ',accu(1)
accu = 0.d0
do ll = 1, n_act_orb
l = list_act(ll)
do kk = 1, n_act_orb
k = list_act(kk)
do jj = 1, n_act_orb
j = list_act(jj)
do ii = 1, n_act_orb
i = list_act(ii)
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
accu(1) += state_av_act_two_rdm_openmp_spin_trace_mo(ii,jj,kk,ll) * integral
enddo
enddo
enddo
enddo
print*,'accu = ',accu(1)
print*,'psi_energy_two_e = ',psi_energy_two_e
end end

26
src/casscf/gradient.irp.f
View File

@ -5,7 +5,7 @@ BEGIN_PROVIDER [ integer, nMonoEx ]
! Number of single excitations ! Number of single excitations
END_DOC END_DOC
implicit none implicit none
nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb nMonoEx=n_core_inact_orb*n_act_orb+n_core_inact_orb*n_virt_orb+n_act_orb*n_virt_orb
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] BEGIN_PROVIDER [integer, excit, (2,nMonoEx)]
@ -17,8 +17,8 @@ END_PROVIDER
implicit none implicit none
integer :: i,t,a,ii,tt,aa,indx integer :: i,t,a,ii,tt,aa,indx
indx=0 indx=0
do ii=1,n_core_orb do ii=1,n_core_inact_orb
i=list_core(ii) i=list_core_inact(ii)
do tt=1,n_act_orb do tt=1,n_act_orb
t=list_act(tt) t=list_act(tt)
indx+=1 indx+=1
@ -28,8 +28,8 @@ END_PROVIDER
end do end do
end do end do
do ii=1,n_core_orb do ii=1,n_core_inact_orb
i=list_core(ii) i=list_core_inact(ii)
do aa=1,n_virt_orb do aa=1,n_virt_orb
a=list_virt(aa) a=list_virt(aa)
indx+=1 indx+=1
@ -145,14 +145,14 @@ BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)]
real*8 :: norm_grad real*8 :: norm_grad
indx=0 indx=0
do i=1,n_core_orb do i=1,n_core_inact_orb
do t=1,n_act_orb do t=1,n_act_orb
indx+=1 indx+=1
gradvec2(indx)=gradvec_it(i,t) gradvec2(indx)=gradvec_it(i,t)
end do end do
end do end do
do i=1,n_core_orb do i=1,n_core_inact_orb
do a=1,n_virt_orb do a=1,n_virt_orb
indx+=1 indx+=1
gradvec2(indx)=gradvec_ia(i,a) gradvec2(indx)=gradvec_ia(i,a)
@ -181,7 +181,7 @@ END_PROVIDER
real*8 function gradvec_it(i,t) real*8 function gradvec_it(i,t)
BEGIN_DOC BEGIN_DOC
! the orbital gradient core -> active ! the orbital gradient core/inactive -> active
! we assume natural orbitals ! we assume natural orbitals
END_DOC END_DOC
implicit none implicit none
@ -190,16 +190,16 @@ real*8 function gradvec_it(i,t)
integer :: ii,tt,v,vv,x,y integer :: ii,tt,v,vv,x,y
integer :: x3,y3 integer :: x3,y3
ii=list_core(i) ii=list_core_inact(i)
tt=list_act(t) tt=list_act(t)
gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii)) gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii))
gradvec_it-=occnum(tt)*Fipq(ii,tt) gradvec_it-=occnum(tt)*Fipq(ii,tt)
do v=1,n_act_orb do v=1,n_act_orb
vv=list_act(v) vv=list_act(v)
do x=1,n_act_orb do x=1,n_act_orb
x3=x+n_core_orb x3=x+n_core_inact_orb
do y=1,n_act_orb do y=1,n_act_orb
y3=y+n_core_orb y3=y+n_core_inact_orb
gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3) gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3)
end do end do
end do end do
@ -209,12 +209,12 @@ end function gradvec_it
real*8 function gradvec_ia(i,a) real*8 function gradvec_ia(i,a)
BEGIN_DOC BEGIN_DOC
! the orbital gradient core -> virtual ! the orbital gradient core/inactive -> virtual
END_DOC END_DOC
implicit none implicit none
integer :: i,a,ii,aa integer :: i,a,ii,aa
ii=list_core(i) ii=list_core_inact(i)
aa=list_virt(a) aa=list_virt(a)
gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii))
gradvec_ia*=2.D0 gradvec_ia*=2.D0

62
src/casscf/hessian.irp.f
View File

@ -204,10 +204,10 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)]
endif endif
indx=1 indx=1
do i=1,n_core_orb do i=1,n_core_inact_orb
do t=1,n_act_orb do t=1,n_act_orb
jndx=indx jndx=indx
do j=i,n_core_orb do j=i,n_core_inact_orb
if (i.eq.j) then if (i.eq.j) then
ustart=t ustart=t
else else
@ -219,7 +219,7 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)]
jndx+=1 jndx+=1
end do end do
end do end do
do j=1,n_core_orb do j=1,n_core_inact_orb
do a=1,n_virt_orb do a=1,n_virt_orb
hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) hessmat2(indx,jndx)=hessmat_itja(i,t,j,a)
hessmat2(jndx,indx)=hessmat2(indx,jndx) hessmat2(jndx,indx)=hessmat2(indx,jndx)
@ -237,10 +237,10 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)]
end do end do
end do end do
do i=1,n_core_orb do i=1,n_core_inact_orb
do a=1,n_virt_orb do a=1,n_virt_orb
jndx=indx jndx=indx
do j=i,n_core_orb do j=i,n_core_inact_orb
if (i.eq.j) then if (i.eq.j) then
bstart=a bstart=a
else else
@ -286,7 +286,7 @@ END_PROVIDER
real*8 function hessmat_itju(i,t,j,u) real*8 function hessmat_itju(i,t,j,u)
BEGIN_DOC BEGIN_DOC
! the orbital hessian for core->act,core->act ! the orbital hessian for core/inactive -> active, core/inactive -> active
! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu ! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu
! !
! we assume natural orbitals ! we assume natural orbitals
@ -295,7 +295,7 @@ real*8 function hessmat_itju(i,t,j,u)
integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj
real*8 :: term,t2 real*8 :: term,t2
ii=list_core(i) ii=list_core_inact(i)
tt=list_act(t) tt=list_act(t)
if (i.eq.j) then if (i.eq.j) then
if (t.eq.u) then if (t.eq.u) then
@ -343,7 +343,7 @@ real*8 function hessmat_itju(i,t,j,u)
end if end if
else else
! it/ju ! it/ju
jj=list_core(j) jj=list_core_inact(j)
uu=list_act(u) uu=list_act(u)
if (t.eq.u) then if (t.eq.u) then
term=occnum(tt)*Fipq(ii,jj) term=occnum(tt)*Fipq(ii,jj)
@ -374,16 +374,16 @@ end function hessmat_itju
real*8 function hessmat_itja(i,t,j,a) real*8 function hessmat_itja(i,t,j,a)
BEGIN_DOC BEGIN_DOC
! the orbital hessian for core->act,core->virt ! the orbital hessian for core/inactive -> active, core/inactive -> virtual
END_DOC END_DOC
implicit none implicit none
integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y
real*8 :: term real*8 :: term
! it/ja ! it/ja
ii=list_core(i) ii=list_core_inact(i)
tt=list_act(t) tt=list_act(t)
jj=list_core(j) jj=list_core_inact(j)
aa=list_virt(a) aa=list_virt(a)
term=2.D0*(4.D0*bielec_pxxq_no(aa,j,i,tt) & term=2.D0*(4.D0*bielec_pxxq_no(aa,j,i,tt) &
-bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt)) -bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt))
@ -407,17 +407,17 @@ end function hessmat_itja
real*8 function hessmat_itua(i,t,u,a) real*8 function hessmat_itua(i,t,u,a)
BEGIN_DOC BEGIN_DOC
! the orbital hessian for core->act,act->virt ! the orbital hessian for core/inactive -> active, active -> virtual
END_DOC END_DOC
implicit none implicit none
integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3
real*8 :: term real*8 :: term
ii=list_core(i) ii=list_core_inact(i)
tt=list_act(t) tt=list_act(t)
t3=t+n_core_orb t3=t+n_core_inact_orb
uu=list_act(u) uu=list_act(u)
u3=u+n_core_orb u3=u+n_core_inact_orb
aa=list_virt(a) aa=list_virt(a)
if (t.eq.u) then if (t.eq.u) then
term=-occnum(tt)*Fipq(aa,ii) term=-occnum(tt)*Fipq(aa,ii)
@ -428,11 +428,11 @@ real*8 function hessmat_itua(i,t,u,a)
+bielec_pxxq_no(aa,t3,u3,ii)) +bielec_pxxq_no(aa,t3,u3,ii))
do v=1,n_act_orb do v=1,n_act_orb
vv=list_act(v) vv=list_act(v)
v3=v+n_core_orb v3=v+n_core_inact_orb
do x=1,n_act_orb do x=1,n_act_orb
integer :: x3 integer :: x3
xx=list_act(x) xx=list_act(x)
x3=x+n_core_orb x3=x+n_core_inact_orb
term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,ii,v3,x3) & term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,ii,v3,x3) &
+(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) &
*bielec_pqxx_no(aa,xx,v3,i)) *bielec_pqxx_no(aa,xx,v3,i))
@ -448,13 +448,13 @@ end function hessmat_itua
real*8 function hessmat_iajb(i,a,j,b) real*8 function hessmat_iajb(i,a,j,b)
BEGIN_DOC BEGIN_DOC
! the orbital hessian for core->virt,core->virt ! the orbital hessian for core/inactive -> virtual, core/inactive -> virtual
END_DOC END_DOC
implicit none implicit none
integer :: i,a,j,b,ii,aa,jj,bb integer :: i,a,j,b,ii,aa,jj,bb
real*8 :: term real*8 :: term
ii=list_core(i) ii=list_core_inact(i)
aa=list_virt(a) aa=list_virt(a)
if (i.eq.j) then if (i.eq.j) then
if (a.eq.b) then if (a.eq.b) then
@ -469,7 +469,7 @@ real*8 function hessmat_iajb(i,a,j,b)
end if end if
else else
! ia/jb ! ia/jb
jj=list_core(j) jj=list_core_inact(j)
bb=list_virt(b) bb=list_virt(b)
term=2.D0*(4.D0*bielec_pxxq_no(aa,i,j,bb)-bielec_pqxx_no(aa,bb,i,j) & term=2.D0*(4.D0*bielec_pxxq_no(aa,i,j,bb)-bielec_pqxx_no(aa,bb,i,j) &
-bielec_pxxq_no(aa,j,i,bb)) -bielec_pxxq_no(aa,j,i,bb))
@ -484,17 +484,17 @@ end function hessmat_iajb
real*8 function hessmat_iatb(i,a,t,b) real*8 function hessmat_iatb(i,a,t,b)
BEGIN_DOC BEGIN_DOC
! the orbital hessian for core->virt,act->virt ! the orbital hessian for core/inactive -> virtual, active -> virtual
END_DOC END_DOC
implicit none implicit none
integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3
real*8 :: term real*8 :: term
ii=list_core(i) ii=list_core_inact(i)
aa=list_virt(a) aa=list_virt(a)
tt=list_act(t) tt=list_act(t)
bb=list_virt(b) bb=list_virt(b)
t3=t+n_core_orb t3=t+n_core_inact_orb
term=occnum(tt)*(4.D0*bielec_pxxq_no(aa,i,t3,bb)-bielec_pxxq_no(aa,t3,i,bb)& term=occnum(tt)*(4.D0*bielec_pxxq_no(aa,i,t3,bb)-bielec_pxxq_no(aa,t3,i,bb)&
-bielec_pqxx_no(aa,bb,i,t3)) -bielec_pqxx_no(aa,bb,i,t3))
if (a.eq.b) then if (a.eq.b) then
@ -533,10 +533,10 @@ real*8 function hessmat_taub(t,a,u,b)
t1-=occnum(tt)*Fipq(tt,tt) t1-=occnum(tt)*Fipq(tt,tt)
do v=1,n_act_orb do v=1,n_act_orb
vv=list_act(v) vv=list_act(v)
v3=v+n_core_orb v3=v+n_core_inact_orb
do x=1,n_act_orb do x=1,n_act_orb
xx=list_act(x) xx=list_act(x)
x3=x+n_core_orb x3=x+n_core_inact_orb
t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) & t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
bielec_pxxq_no(aa,x3,v3,aa)) bielec_pxxq_no(aa,x3,v3,aa))
@ -552,10 +552,10 @@ real*8 function hessmat_taub(t,a,u,b)
term=occnum(tt)*Fipq(aa,bb) term=occnum(tt)*Fipq(aa,bb)
do v=1,n_act_orb do v=1,n_act_orb
vv=list_act(v) vv=list_act(v)
v3=v+n_core_orb v3=v+n_core_inact_orb
do x=1,n_act_orb do x=1,n_act_orb
xx=list_act(x) xx=list_act(x)
x3=x+n_core_orb x3=x+n_core_inact_orb
term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) &
*bielec_pxxq_no(aa,x3,v3,bb)) *bielec_pxxq_no(aa,x3,v3,bb))
@ -569,10 +569,10 @@ real*8 function hessmat_taub(t,a,u,b)
term=0.D0 term=0.D0
do v=1,n_act_orb do v=1,n_act_orb
vv=list_act(v) vv=list_act(v)
v3=v+n_core_orb v3=v+n_core_inact_orb
do x=1,n_act_orb do x=1,n_act_orb
xx=list_act(x) xx=list_act(x)
x3=x+n_core_orb x3=x+n_core_inact_orb
term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) &
*bielec_pxxq_no(aa,x3,v3,bb)) *bielec_pxxq_no(aa,x3,v3,bb))
@ -606,14 +606,14 @@ BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)]
real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub
indx=0 indx=0
do i=1,n_core_orb do i=1,n_core_inact_orb
do t=1,n_act_orb do t=1,n_act_orb
indx+=1 indx+=1
hessdiag(indx)=hessmat_itju(i,t,i,t) hessdiag(indx)=hessmat_itju(i,t,i,t)
end do end do
end do end do
do i=1,n_core_orb do i=1,n_core_inact_orb
do a=1,n_virt_orb do a=1,n_virt_orb
indx+=1 indx+=1
hessdiag(indx)=hessmat_iajb(i,a,i,a) hessdiag(indx)=hessmat_iajb(i,a,i,a)

4
src/casscf/mcscf_fock.irp.f
View File

@ -12,8 +12,8 @@ BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ]
end do end do
! the inactive Fock matrix ! the inactive Fock matrix
do k=1,n_core_orb do k=1,n_core_inact_orb
kk=list_core(k) kk=list_core_inact(k)
do q=1,mo_num do q=1,mo_num
do p=1,mo_num do p=1,mo_num
Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q) Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q)

4
src/casscf/natorb.irp.f
View File

@ -6,8 +6,8 @@
integer :: i integer :: i
occnum=0.D0 occnum=0.D0
do i=1,n_core_orb do i=1,n_core_inact_orb
occnum(list_core(i))=2.D0 occnum(list_core_inact(i))=2.D0
end do end do
do i=1,n_act_orb do i=1,n_act_orb

8
src/casscf/neworbs.irp.f
View File

@ -125,8 +125,8 @@ BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
! the orbital rotation matrix T ! the orbital rotation matrix T
Tmat(:,:)=0.D0 Tmat(:,:)=0.D0
indx=1 indx=1
do i=1,n_core_orb do i=1,n_core_inact_orb
ii=list_core(i) ii=list_core_inact(i)
do t=1,n_act_orb do t=1,n_act_orb
tt=list_act(t) tt=list_act(t)
indx+=1 indx+=1
@ -134,8 +134,8 @@ BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
Tmat(tt,ii)=-SXvector(indx) Tmat(tt,ii)=-SXvector(indx)
end do end do
end do end do
do i=1,n_core_orb do i=1,n_core_inact_orb
ii=list_core(i) ii=list_core_inact(i)
do a=1,n_virt_orb do a=1,n_virt_orb
aa=list_virt(a) aa=list_virt(a)
indx+=1 indx+=1

36
src/casscf/tot_en.irp.f
View File

@ -10,19 +10,19 @@
real*8 :: e_one_all,e_two_all real*8 :: e_one_all,e_two_all
e_one_all=0.D0 e_one_all=0.D0
e_two_all=0.D0 e_two_all=0.D0
do i=1,n_core_orb do i=1,n_core_inact_orb
ii=list_core(i) ii=list_core_inact(i)
e_one_all+=2.D0*mo_one_e_integrals(ii,ii) e_one_all+=2.D0*mo_one_e_integrals(ii,ii)
do j=1,n_core_orb do j=1,n_core_inact_orb
jj=list_core(j) jj=list_core_inact(j)
e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i)
end do end do
do t=1,n_act_orb do t=1,n_act_orb
tt=list_act(t) tt=list_act(t)
t3=t+n_core_orb t3=t+n_core_inact_orb
do u=1,n_act_orb do u=1,n_act_orb
uu=list_act(u) uu=list_act(u)
u3=u+n_core_orb u3=u+n_core_inact_orb
e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) &
-bielec_PQxx(tt,ii,i,u3)) -bielec_PQxx(tt,ii,i,u3))
end do end do
@ -34,9 +34,9 @@
uu=list_act(u) uu=list_act(u)
e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu) e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu)
do v=1,n_act_orb do v=1,n_act_orb
v3=v+n_core_orb v3=v+n_core_inact_orb
do x=1,n_act_orb do x=1,n_act_orb
x3=x+n_core_orb x3=x+n_core_inact_orb
e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3) e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3)
end do end do
end do end do
@ -44,12 +44,12 @@
end do end do
ecore =nuclear_repulsion ecore =nuclear_repulsion
ecore_bis=nuclear_repulsion ecore_bis=nuclear_repulsion
do i=1,n_core_orb do i=1,n_core_inact_orb
ii=list_core(i) ii=list_core_inact(i)
ecore +=2.D0*mo_one_e_integrals(ii,ii) ecore +=2.D0*mo_one_e_integrals(ii,ii)
ecore_bis+=2.D0*mo_one_e_integrals(ii,ii) ecore_bis+=2.D0*mo_one_e_integrals(ii,ii)
do j=1,n_core_orb do j=1,n_core_inact_orb
jj=list_core(j) jj=list_core_inact(j)
ecore +=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) ecore +=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i)
ecore_bis+=2.D0*bielec_PxxQ(ii,i,j,jj)-bielec_PxxQ(ii,j,j,ii) ecore_bis+=2.D0*bielec_PxxQ(ii,i,j,jj)-bielec_PxxQ(ii,j,j,ii)
end do end do
@ -61,14 +61,14 @@
etwo_ter=0.D0 etwo_ter=0.D0
do t=1,n_act_orb do t=1,n_act_orb
tt=list_act(t) tt=list_act(t)
t3=t+n_core_orb t3=t+n_core_inact_orb
do u=1,n_act_orb do u=1,n_act_orb
uu=list_act(u) uu=list_act(u)
u3=u+n_core_orb u3=u+n_core_inact_orb
eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu) eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu)
eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu) eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu)
do i=1,n_core_orb do i=1,n_core_inact_orb
ii=list_core(i) ii=list_core_inact(i)
eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) &
-bielec_PQxx(tt,ii,i,u3)) -bielec_PQxx(tt,ii,i,u3))
eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) & eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) &
@ -76,10 +76,10 @@
end do end do
do v=1,n_act_orb do v=1,n_act_orb
vv=list_act(v) vv=list_act(v)
v3=v+n_core_orb v3=v+n_core_inact_orb
do x=1,n_act_orb do x=1,n_act_orb
xx=list_act(x) xx=list_act(x)
x3=x+n_core_orb x3=x+n_core_inact_orb
real*8 :: h1,h2,h3 real*8 :: h1,h2,h3
h1=bielec_PQxx(tt,uu,v3,x3) h1=bielec_PQxx(tt,uu,v3,x3)
h2=bielec_PxxQ(tt,u3,v3,xx) h2=bielec_PxxQ(tt,u3,v3,xx)

2
src/davidson/u0_wee_u0.irp.f
View File

@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, psi_energy_two_e, (N_states) ]
integer :: i,j integer :: i,j
call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
do i=N_det+1,N_states do i=N_det+1,N_states
psi_energy(i) = 0.d0 psi_energy_two_e(i) = 0.d0
enddo enddo
END_PROVIDER END_PROVIDER

35
src/selectors_full/selectors.irp.f
View File

@ -38,35 +38,18 @@ END_PROVIDER
END_DOC END_DOC
integer :: i,k integer :: i,k
! if (threshold_selectors == 1.d0) then do i=1,N_det_selectors
! do k=1,N_int
! do i=1,N_det_selectors psi_selectors(k,1,i) = psi_det_sorted(k,1,i)
! do k=1,N_int psi_selectors(k,2,i) = psi_det_sorted(k,2,i)
! psi_selectors(k,1,i) = psi_det(k,1,i) enddo
! psi_selectors(k,2,i) = psi_det(k,2,i) enddo
! enddo do k=1,N_states
! enddo
! do k=1,N_states
! do i=1,N_det_selectors
! psi_selectors_coef(i,k) = psi_coef(i,k)
! enddo
! enddo
!
! else
do i=1,N_det_selectors do i=1,N_det_selectors
do k=1,N_int psi_selectors_coef(i,k) = psi_coef_sorted(i,k)
psi_selectors(k,1,i) = psi_det_sorted(k,1,i)
psi_selectors(k,2,i) = psi_det_sorted(k,2,i)
enddo
enddo
do k=1,N_states
do i=1,N_det_selectors
psi_selectors_coef(i,k) = psi_coef_sorted(i,k)
enddo
enddo enddo
enddo
! endif
END_PROVIDER END_PROVIDER

18
src/two_body_rdm/ab_only_routines.irp.f
View File

@ -1,5 +1,5 @@
subroutine two_rdm_ab_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) subroutine two_rdm_ab_nstates(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -27,7 +27,7 @@
size(u_t, 1), & size(u_t, 1), &
N_det, N_st) N_det, N_st)
call two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) call two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t) deallocate(u_t)
do k=1,N_st do k=1,N_st
@ -37,7 +37,7 @@
end end
subroutine two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) subroutine two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -55,20 +55,20 @@
select case (N_int) select case (N_int)
case (1) case (1)
call two_rdm_ab_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call two_rdm_ab_nstates_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (2) case (2)
call two_rdm_ab_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call two_rdm_ab_nstates_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (3) case (3)
call two_rdm_ab_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call two_rdm_ab_nstates_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (4) case (4)
call two_rdm_ab_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call two_rdm_ab_nstates_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case default case default
call two_rdm_ab_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call two_rdm_ab_nstates_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
end select end select
end end
BEGIN_TEMPLATE BEGIN_TEMPLATE
subroutine two_rdm_ab_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) subroutine two_rdm_ab_nstates_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep integer, intent(in) :: N_st,sze,istart,iend,ishift,istep

18
src/two_body_rdm/all_2rdm_routines.irp.f
View File

@ -1,4 +1,4 @@
subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) subroutine all_two_rdm_dm_nstates(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -28,7 +28,7 @@ subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,
size(u_t, 1), & size(u_t, 1), &
N_det, N_st) N_det, N_st)
call all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) call all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t) deallocate(u_t)
do k=1,N_st do k=1,N_st
@ -38,7 +38,7 @@ subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,
end end
subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) subroutine all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -58,21 +58,21 @@ subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_arra
select case (N_int) select case (N_int)
case (1) case (1)
call all_two_rdm_dm_nstates_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call all_two_rdm_dm_nstates_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (2) case (2)
call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call all_two_rdm_dm_nstates_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (3) case (3)
call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call all_two_rdm_dm_nstates_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (4) case (4)
call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call all_two_rdm_dm_nstates_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case default case default
call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) call all_two_rdm_dm_nstates_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
end select end select
end end
BEGIN_TEMPLATE BEGIN_TEMPLATE
subroutine all_two_rdm_dm_nstates_openmp_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) subroutine all_two_rdm_dm_nstates_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC

8
src/two_body_rdm/all_states_2_rdm.irp.f
View File

@ -14,7 +14,7 @@
! condition for alpha/beta spin ! condition for alpha/beta spin
ispin = 1 ispin = 1
all_states_act_two_rdm_alpha_alpha_mo = 0.D0 all_states_act_two_rdm_alpha_alpha_mo = 0.D0
call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER END_PROVIDER
@ -31,7 +31,7 @@
! condition for alpha/beta spin ! condition for alpha/beta spin
ispin = 2 ispin = 2
all_states_act_two_rdm_beta_beta_mo = 0.d0 all_states_act_two_rdm_beta_beta_mo = 0.d0
call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_all_states_two_rdm(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER END_PROVIDER
@ -53,7 +53,7 @@
ispin = 3 ispin = 3
print*,'ispin = ',ispin print*,'ispin = ',ispin
all_states_act_two_rdm_alpha_beta_mo = 0.d0 all_states_act_two_rdm_alpha_beta_mo = 0.d0
call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER END_PROVIDER
@ -77,7 +77,7 @@
all_states_act_two_rdm_spin_trace_mo = 0.d0 all_states_act_two_rdm_spin_trace_mo = 0.d0
integer :: i integer :: i
call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_all_states_two_rdm(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER END_PROVIDER

20
src/two_body_rdm/all_states_routines.irp.f
View File

@ -1,4 +1,4 @@
subroutine orb_range_all_states_two_rdm_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze) subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -31,7 +31,7 @@ subroutine orb_range_all_states_two_rdm_openmp(big_array,dim1,norb,list_orb,list
size(u_t, 1), & size(u_t, 1), &
N_det, N_st) N_det, N_st)
call orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1) call orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t) deallocate(u_t)
do k=1,N_st do k=1,N_st
@ -40,7 +40,7 @@ subroutine orb_range_all_states_two_rdm_openmp(big_array,dim1,norb,list_orb,list
end end
subroutine orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) subroutine orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -60,15 +60,15 @@ subroutine orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb
select case (N_int) select case (N_int)
case (1) case (1)
call orb_range_all_states_two_rdm_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_all_states_two_rdm_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (2) case (2)
call orb_range_all_states_two_rdm_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_all_states_two_rdm_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (3) case (3)
call orb_range_all_states_two_rdm_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_all_states_two_rdm_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (4) case (4)
call orb_range_all_states_two_rdm_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_all_states_two_rdm_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case default case default
call orb_range_all_states_two_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_all_states_two_rdm_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
end select end select
end end
@ -76,7 +76,7 @@ end
BEGIN_TEMPLATE BEGIN_TEMPLATE
subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -129,7 +129,7 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l
else if(ispin == 4)then else if(ispin == 4)then
spin_trace = .True. spin_trace = .True.
else else
print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_openmp_work' print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_work'
print*,'ispin = ',ispin print*,'ispin = ',ispin
stop stop
endif endif

8
src/two_body_rdm/orb_range_2_rdm.irp.f
View File

@ -14,7 +14,7 @@
! condition for alpha/beta spin ! condition for alpha/beta spin
ispin = 1 ispin = 1
state_av_act_two_rdm_alpha_alpha_mo = 0.D0 state_av_act_two_rdm_alpha_alpha_mo = 0.D0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER END_PROVIDER
@ -31,7 +31,7 @@
! condition for alpha/beta spin ! condition for alpha/beta spin
ispin = 2 ispin = 2
state_av_act_two_rdm_beta_beta_mo = 0.d0 state_av_act_two_rdm_beta_beta_mo = 0.d0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_two_rdm_state_av(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER END_PROVIDER
@ -53,7 +53,7 @@
ispin = 3 ispin = 3
print*,'ispin = ',ispin print*,'ispin = ',ispin
state_av_act_two_rdm_alpha_beta_mo = 0.d0 state_av_act_two_rdm_alpha_beta_mo = 0.d0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER END_PROVIDER
@ -79,7 +79,7 @@
double precision :: wall_0,wall_1 double precision :: wall_0,wall_1
call wall_time(wall_0) call wall_time(wall_0)
print*,'providing the state average TWO-RDM ...' print*,'providing the state average TWO-RDM ...'
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call orb_range_two_rdm_state_av(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(wall_1) call wall_time(wall_1)
print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0 print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0

87
src/two_body_rdm/orb_range_2_rdm_openmp.irp.f Normal file
View File

@ -0,0 +1,87 @@
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_openmp_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
ispin = 1
state_av_act_two_rdm_openmp_alpha_alpha_mo = 0.D0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_openmp_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
ispin = 2
state_av_act_two_rdm_openmp_beta_beta_mo = 0.d0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_openmp_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
! = <Psi| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
print*,''
print*,''
print*,''
print*,'providint state_av_act_two_rdm_openmp_alpha_beta_mo '
ispin = 3
print*,'ispin = ',ispin
state_av_act_two_rdm_openmp_alpha_beta_mo = 0.d0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
BEGIN_DOC
! state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
! The active part of the two-electron energy can be computed as:
!
! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) * < ii jj | kk ll >
!
! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l)
END_DOC
double precision, allocatable :: state_weights(:)
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
ispin = 4
state_av_act_two_rdm_openmp_spin_trace_mo = 0.d0
integer :: i
double precision :: wall_0,wall_1
call wall_time(wall_0)
print*,'providing the state average TWO-RDM ...'
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(wall_1)
print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0
END_PROVIDER

20
src/two_body_rdm/orb_range_routines.irp.f
View File

@ -1,4 +1,4 @@
subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -31,7 +31,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,list_o
size(u_t, 1), & size(u_t, 1), &
N_det, N_st) N_det, N_st)
call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t) deallocate(u_t)
do k=1,N_st do k=1,N_st
@ -40,7 +40,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,list_o
end end
subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -60,15 +60,15 @@ subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,l
select case (N_int) select case (N_int)
case (1) case (1)
call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_two_rdm_state_av_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (2) case (2)
call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_two_rdm_state_av_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (3) case (3)
call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_two_rdm_state_av_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (4) case (4)
call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_two_rdm_state_av_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case default case default
call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) call orb_range_two_rdm_state_av_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
end select end select
end end
@ -76,7 +76,7 @@ end
BEGIN_TEMPLATE BEGIN_TEMPLATE
subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -130,7 +130,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
else if(ispin == 4)then else if(ispin == 4)then
spin_trace = .True. spin_trace = .True.
else else
print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work' print*,'Wrong parameter for ispin in general_two_rdm_state_av_work'
print*,'ispin = ',ispin print*,'ispin = ',ispin
stop stop
endif endif

544
src/two_body_rdm/orb_range_routines_openmp.irp.f Normal file
View File

@ -0,0 +1,544 @@
subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
! if ispin == 1 :: alpha/alpha 2rdm
! == 2 :: beta /beta 2rdm
! == 3 :: alpha/beta 2rdm
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
!
! Assumes that the determinants are in psi_det
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
integer, intent(in) :: N_st,sze
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st)
integer :: k
double precision, allocatable :: u_t(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
allocate(u_t(N_st,N_det))
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
enddo
call dtranspose( &
u_0, &
size(u_0, 1), &
u_t, &
size(u_t, 1), &
N_det, N_st)
call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t)
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
enddo
end
subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes two-rdm
!
! Default should be 1,N_det,0,1
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
integer :: k
PROVIDE N_int
select case (N_int)
case (1)
call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (2)
call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (3)
call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (4)
call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case default
call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
end select
end
BEGIN_TEMPLATE
subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes the two rdm for the N_st vectors |u_t>
! if ispin == 1 :: alpha/alpha 2rdm
! == 2 :: beta /beta 2rdm
! == 3 :: alpha/beta 2rdm
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb
! In any cases, the state average weights will be used with an array state_weights
! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer :: i,j,k,l
integer :: k_a, k_b, l_a, l_b, m_a, m_b
integer :: istate
integer :: krow, kcol, krow_b, kcol_b
integer :: lrow, lcol
integer :: mrow, mcol
integer(bit_kind) :: spindet($N_int)
integer(bit_kind) :: tmp_det($N_int,2)
integer(bit_kind) :: tmp_det2($N_int,2)
integer(bit_kind) :: tmp_det3($N_int,2)
integer(bit_kind), allocatable :: buffer(:,:)
integer :: n_doubles
integer, allocatable :: doubles(:)
integer, allocatable :: singles_a(:)
integer, allocatable :: singles_b(:)
integer, allocatable :: idx(:), idx0(:)
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
integer*8 :: k8
double precision :: c_average
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
integer(bit_kind) :: orb_bitmask($N_int)
integer :: list_orb_reverse(mo_num)
integer, allocatable :: keys(:,:)
double precision, allocatable :: values(:)
integer :: nkeys,sze_buff
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work'
print*,'ispin = ',ispin
stop
endif
!do i = 1, N_int
! det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
! det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
!enddo
PROVIDE N_int
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
sze_buff = norb ** 3
list_orb_reverse = -1000
do i = 1, norb
list_orb_reverse(list_orb(i)) = i
enddo
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
allocate(idx0(maxab))
do i=1,maxab
idx0(i) = i
enddo
! Prepare the array of all alpha single excitations
! -------------------------------------------------
PROVIDE N_int nthreads_davidson
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
! !$OMP psi_bilinear_matrix_columns, &
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
! !$OMP psi_bilinear_matrix_transp_rows, &
! !$OMP psi_bilinear_matrix_transp_columns, &
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
! !$OMP psi_bilinear_matrix_columns_loc, &
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
! !$OMP ishift, idx0, u_t, maxab) &
! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,&
! !$OMP lcol, lrow, l_a, l_b, &
! !$OMP buffer, doubles, n_doubles, &
! !$OMP tmp_det2, idx, l, kcol_prev, &
! !$OMP singles_a, n_singles_a, singles_b, &
! !$OMP n_singles_b, k8)
! Alpha/Beta double excitations
! =============================
nkeys = 0
allocate( keys(4,sze_buff), values(sze_buff))
allocate( buffer($N_int,maxab), &
singles_a(maxab), &
singles_b(maxab), &
doubles(maxab), &
idx(maxab))
kcol_prev=-1
ASSERT (iend <= N_det)
ASSERT (istart > 0)
ASSERT (istep > 0)
!!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
if (kcol /= kcol_prev) then
call get_all_spin_singles_$N_int( &
psi_det_beta_unique, idx0, &
tmp_det(1,2), N_det_beta_unique, &
singles_b, n_singles_b)
endif
kcol_prev = kcol
! Loop over singly excited beta columns
! -------------------------------------
do i=1,n_singles_b
lcol = singles_b(i)
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det)
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
ASSERT (l_a <= N_det)
idx(j) = l_a
l_a = l_a+1
enddo
j = j-1
call get_all_spin_singles_$N_int( &
buffer, idx, tmp_det(1,1), j, &
singles_a, n_singles_a )
! Loop over alpha singles
! -----------------------
if(alpha_beta.or.spin_trace)then
do k = 1,n_singles_a
l_a = singles_a(k)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
enddo
if(alpha_beta)then
! only ONE contribution
if (nkeys+1 .ge. size(values)) then
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
endif
else if (spin_trace)then
! TWO contributions
if (nkeys+2 .ge. size(values)) then
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
endif
endif
call orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo
endif
enddo
enddo
! !$OMP END DO
! !$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
! Single and double alpha exitations
! ===================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
! Initial determinant is at k_b in beta-major representation
! ----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
ASSERT (k_b <= N_det)
spindet(1:$N_int) = tmp_det(1:$N_int,1)
! Loop inside the beta column to gather all the connected alphas
lcol = psi_bilinear_matrix_columns(k_a)
l_a = psi_bilinear_matrix_columns_loc(lcol)
do i=1,N_det_alpha_unique
if (l_a > N_det) exit
lcol = psi_bilinear_matrix_columns(l_a)
if (lcol /= kcol) exit
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
idx(i) = l_a
l_a = l_a+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_a, doubles, n_singles_a, n_doubles )
! Compute Hij for all alpha singles
! ----------------------------------
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
do i=1,n_singles_a
l_a = singles_a(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
enddo
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
! increment the alpha/beta part for single excitations
!!!! call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
! increment the alpha/alpha part for single excitations
!!!! call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
endif
enddo
! Compute Hij for all alpha doubles
! ----------------------------------
if(alpha_alpha.or.spin_trace)then
do i=1,n_doubles
l_a = doubles(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
enddo
!!!! call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
enddo
endif
! Single and double beta excitations
! ==================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
kcol = psi_bilinear_matrix_columns(k_a)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
spindet(1:$N_int) = tmp_det(1:$N_int,2)
! Initial determinant is at k_b in beta-major representation
! -----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
ASSERT (k_b <= N_det)
! Loop inside the alpha row to gather all the connected betas
lrow = psi_bilinear_matrix_transp_rows(k_b)
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
do i=1,N_det_beta_unique
if (l_b > N_det) exit
lrow = psi_bilinear_matrix_transp_rows(l_b)
if (lrow /= krow) exit
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
idx(i) = l_b
l_b = l_b+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_b, doubles, n_singles_b, n_doubles )
! Compute Hij for all beta singles
! ----------------------------------
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
do i=1,n_singles_b
l_b = singles_b(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
l_a = psi_bilinear_matrix_transp_order(l_b)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
enddo
if(alpha_beta.or.spin_trace.or.beta_beta)then
! increment the alpha/beta part for single excitations
!!!! call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
! increment the beta /beta part for single excitations
!!!! call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
endif
enddo
! Compute Hij for all beta doubles
! ----------------------------------
if(beta_beta.or.spin_trace)then
do i=1,n_doubles
l_b = doubles(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
l_a = psi_bilinear_matrix_transp_order(l_b)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
enddo
!!!! call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
ASSERT (l_a <= N_det)
enddo
endif
! Diagonal contribution
! =====================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
double precision :: c_1(N_states),c_2(N_states)
c_average = 0.d0
do l = 1, N_states
c_1(l) = u_t(l,k_a)
c_average += c_1(l) * c_1(l) * state_weights(l)
enddo
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
call orb_range_diag_to_all_two_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
end do
!!$OMP END DO
deallocate(buffer, singles_a, singles_b, doubles, idx)
!!$OMP END PARALLEL
end
SUBST [ N_int ]
1;;
2;;
3;;
4;;
N_int;;
END_TEMPLATE
subroutine update_keys_values(keys,values,size_buff,nkeys,dim1,big_array)
implicit none
integer, intent(in) :: size_buff,nkeys,dim1
integer, intent(in) :: keys(4,size_buff)
double precision, intent(in) :: values(size_buff)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer :: i,h1,h2,p1,p2
do i = 1, nkeys
h1 = keys(1,i)
h2 = keys(2,i)
p1 = keys(3,i)
p2 = keys(4,i)
big_array(h1,h2,p1,p2) += values(i)
enddo
end

683
src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f Normal file
View File

@ -0,0 +1,683 @@
subroutine orb_range_diag_to_all_two_rdm_dm_buffer(det_1,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: det_1(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1
double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate
integer(bit_kind) :: det_1_act(N_int,2)
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
do i = 1, N_int
det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
enddo
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
logical :: is_integer_in_string
integer :: i1,i2
if(alpha_beta)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
values(nkeys) = c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
enddo
enddo
else if (alpha_alpha)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
values(nkeys) = 0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
values(nkeys) = -0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
else if (beta_beta)then
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
values(nkeys) = 0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
values(nkeys) = -0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
else if(spin_trace)then
! 0.5 * (alpha beta + beta alpha)
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
values(nkeys) = 0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
values(nkeys) = 0.5d0 * c_1
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
values(nkeys) = 0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
values(nkeys) = -0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
values(nkeys) = 0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
values(nkeys) = -0.5d0 * c_1
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
endif
end
subroutine orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation(det_1,det_2,exc,phase,N_int)
h1 = exc(1,1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
h2 = exc(1,1,2)
if(list_orb_reverse(h2).lt.0)return
h2 = list_orb_reverse(h2)
p1 = exc(1,2,1)
if(list_orb_reverse(p1).lt.0)return
p1 = list_orb_reverse(p1)
p2 = exc(1,2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(alpha_beta)then
nkeys += 1
values(nkeys) = c_1 * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
else if(spin_trace)then
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
keys(1,nkeys) = p1
keys(2,nkeys) = p2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
endif
end
! subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin)
! use bitmasks
! BEGIN_DOC
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!!
!! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
!!
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!!
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!!
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!!
!! ispin determines which spin-spin component of the two-rdm you will update
!!
!! ispin == 1 :: alpha/ alpha
!! ispin == 2 :: beta / beta
!! ispin == 3 :: alpha/ beta
!! ispin == 4 :: spin traced <=> total two-rdm
!!
!! here, only ispin == 3 or 4 will do something
! END_DOC
! implicit none
! integer, intent(in) :: dim1,ispin
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int)
! integer, intent(in) :: list_orb_reverse(mo_num)
! double precision, intent(in) :: c_1
!
! integer :: occ(N_int*bit_kind_size,2)
! integer :: n_occ_ab(2)
! integer :: i,j,h1,h2,istate,p1
! integer :: exc(0:2,2,2)
! double precision :: phase
!
! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
! logical :: is_integer_in_string
! alpha_alpha = .False.
! beta_beta = .False.
! alpha_beta = .False.
! spin_trace = .False.
! if( ispin == 1)then
! alpha_alpha = .True.
! else if(ispin == 2)then
! beta_beta = .True.
! else if(ispin == 3)then
! alpha_beta = .True.
! else if(ispin == 4)then
! spin_trace = .True.
! endif
!
! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! call get_single_excitation(det_1,det_2,exc,phase,N_int)
! if(alpha_beta)then
! if (exc(0,1,1) == 1) then
! ! Mono alpha
! h1 = exc(1,1,1)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! p1 = exc(1,2,1)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! do i = 1, n_occ_ab(2)
! h2 = occ(i,2)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
! h2 = list_orb_reverse(h2)
! big_array(h1,h2,p1,h2) += c_1 * phase
! enddo
! else
! ! Mono beta
! h1 = exc(1,1,2)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! p1 = exc(1,2,2)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! do i = 1, n_occ_ab(1)
! h2 = occ(i,1)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
! h2 = list_orb_reverse(h2)
! big_array(h2,h1,h2,p1) += c_1 * phase
! enddo
! endif
! else if(spin_trace)then
! if (exc(0,1,1) == 1) then
! ! Mono alpha
! h1 = exc(1,1,1)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! p1 = exc(1,2,1)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! do i = 1, n_occ_ab(2)
! h2 = occ(i,2)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
! h2 = list_orb_reverse(h2)
! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
! enddo
! else
! ! Mono beta
! h1 = exc(1,1,2)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! p1 = exc(1,2,2)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! do i = 1, n_occ_ab(1)
! h2 = occ(i,1)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
! h2 = list_orb_reverse(h2)
! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
! enddo
! endif
! endif
! end
! subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin)
! BEGIN_DOC
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!!
!! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
!!
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!!
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!!
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!!
!! ispin determines which spin-spin component of the two-rdm you will update
!!
!! ispin == 1 :: alpha/ alpha
!! ispin == 2 :: beta / beta
!! ispin == 3 :: alpha/ beta
!! ispin == 4 :: spin traced <=> total two-rdm
!!
!! here, only ispin == 1 or 4 will do something
! END_DOC
! use bitmasks
! implicit none
! integer, intent(in) :: dim1,ispin
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int)
! integer, intent(in) :: list_orb_reverse(mo_num)
! double precision, intent(in) :: c_1
!
! integer :: occ(N_int*bit_kind_size,2)
! integer :: n_occ_ab(2)
! integer :: i,j,h1,h2,istate,p1
! integer :: exc(0:2,2,2)
! double precision :: phase
!
! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
! logical :: is_integer_in_string
! alpha_alpha = .False.
! beta_beta = .False.
! alpha_beta = .False.
! spin_trace = .False.
! if( ispin == 1)then
! alpha_alpha = .True.
! else if(ispin == 2)then
! beta_beta = .True.
! else if(ispin == 3)then
! alpha_beta = .True.
! else if(ispin == 4)then
! spin_trace = .True.
! endif
!
! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! call get_single_excitation(det_1,det_2,exc,phase,N_int)
! if(alpha_alpha.or.spin_trace)then
! if (exc(0,1,1) == 1) then
! ! Mono alpha
! h1 = exc(1,1,1)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! p1 = exc(1,2,1)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! do i = 1, n_occ_ab(1)
! h2 = occ(i,1)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
! h2 = list_orb_reverse(h2)
! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
!
! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
! enddo
! else
! return
! endif
! endif
! end
! subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin)
! use bitmasks
! BEGIN_DOC
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!!
!! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
!!
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!!
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!!
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!!
!! ispin determines which spin-spin component of the two-rdm you will update
!!
!! ispin == 1 :: alpha/ alpha
!! ispin == 2 :: beta / beta
!! ispin == 3 :: alpha/ beta
!! ispin == 4 :: spin traced <=> total two-rdm
!!
!! here, only ispin == 2 or 4 will do something
! END_DOC
! implicit none
! integer, intent(in) :: dim1,ispin
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int)
! integer, intent(in) :: list_orb_reverse(mo_num)
! double precision, intent(in) :: c_1
!
!
! integer :: occ(N_int*bit_kind_size,2)
! integer :: n_occ_ab(2)
! integer :: i,j,h1,h2,istate,p1
! integer :: exc(0:2,2,2)
! double precision :: phase
! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
! logical :: is_integer_in_string
! alpha_alpha = .False.
! beta_beta = .False.
! alpha_beta = .False.
! spin_trace = .False.
! if( ispin == 1)then
! alpha_alpha = .True.
! else if(ispin == 2)then
! beta_beta = .True.
! else if(ispin == 3)then
! alpha_beta = .True.
! else if(ispin == 4)then
! spin_trace = .True.
! endif
!
!
! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! call get_single_excitation(det_1,det_2,exc,phase,N_int)
! if(beta_beta.or.spin_trace)then
! if (exc(0,1,1) == 1) then
! return
! else
! ! Mono beta
! h1 = exc(1,1,2)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! p1 = exc(1,2,2)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! do istate = 1, N_states
! do i = 1, n_occ_ab(2)
! h2 = occ(i,2)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
! h2 = list_orb_reverse(h2)
! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
!
! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
! enddo
! enddo
! endif
! endif
! end
! subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin)
! use bitmasks
! BEGIN_DOC
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!!
!! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
!!
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!!
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!!
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!!
!! ispin determines which spin-spin component of the two-rdm you will update
!!
!! ispin == 1 :: alpha/ alpha
!! ispin == 2 :: beta / beta
!! ispin == 3 :: alpha/ beta
!! ispin == 4 :: spin traced <=> total two-rdm
!!
!! here, only ispin == 1 or 4 will do something
! END_DOC
! implicit none
! integer, intent(in) :: dim1,ispin
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int)
! integer, intent(in) :: list_orb_reverse(mo_num)
! double precision, intent(in) :: c_1
!
! integer :: i,j,h1,h2,p1,p2,istate
! integer :: exc(0:2,2)
! double precision :: phase
!
! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
! logical :: is_integer_in_string
! alpha_alpha = .False.
! beta_beta = .False.
! alpha_beta = .False.
! spin_trace = .False.
! if( ispin == 1)then
! alpha_alpha = .True.
! else if(ispin == 2)then
! beta_beta = .True.
! else if(ispin == 3)then
! alpha_beta = .True.
! else if(ispin == 4)then
! spin_trace = .True.
! endif
! call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
! h1 =exc(1,1)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! h2 =exc(2,1)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
! h2 = list_orb_reverse(h2)
! p1 =exc(1,2)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! p2 =exc(2,2)
! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
! p2 = list_orb_reverse(p2)
! if(alpha_alpha.or.spin_trace)then
! do istate = 1, N_states
! big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase
! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase
!
! big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase
! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase
! enddo
! endif
! end
! subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin)
! use bitmasks
! BEGIN_DOC
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!!
!! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
!!
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!!
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!!
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!!
!! ispin determines which spin-spin component of the two-rdm you will update
!!
!! ispin == 1 :: alpha/ alpha
!! ispin == 2 :: beta / beta
!! ispin == 3 :: alpha/ beta
!! ispin == 4 :: spin traced <=> total two-rdm
!!
!! here, only ispin == 2 or 4 will do something
! END_DOC
! implicit none
!
! integer, intent(in) :: dim1,ispin
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int)
! integer, intent(in) :: list_orb_reverse(mo_num)
! double precision, intent(in) :: c_1
!
! integer :: i,j,h1,h2,p1,p2,istate
! integer :: exc(0:2,2)
! double precision :: phase
! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
! logical :: is_integer_in_string
! alpha_alpha = .False.
! beta_beta = .False.
! alpha_beta = .False.
! spin_trace = .False.
! if( ispin == 1)then
! alpha_alpha = .True.
! else if(ispin == 2)then
! beta_beta = .True.
! else if(ispin == 3)then
! alpha_beta = .True.
! else if(ispin == 4)then
! spin_trace = .True.
! endif
!
! call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
! h1 =exc(1,1)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! h2 =exc(2,1)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
! h2 = list_orb_reverse(h2)
! p1 =exc(1,2)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! p2 =exc(2,2)
! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
! p2 = list_orb_reverse(p2)
! if(beta_beta.or.spin_trace)then
! big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase
! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase
!
! big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase
! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase
! endif
! end

2
src/two_body_rdm/two_rdm.irp.f
View File

@ -19,7 +19,7 @@
two_rdm_beta_beta_mo = 0.d0 two_rdm_beta_beta_mo = 0.d0
print*,'providing two_rdm_alpha_beta ...' print*,'providing two_rdm_alpha_beta ...'
call wall_time(cpu_0) call wall_time(cpu_0)
call all_two_rdm_dm_nstates_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) call all_two_rdm_dm_nstates(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(cpu_1) call wall_time(cpu_1)
print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0)