diff --git a/ocaml/qp_tunnel.ml b/ocaml/qp_tunnel.ml index 75112e66..e7322995 100644 --- a/ocaml/qp_tunnel.ml +++ b/ocaml/qp_tunnel.ml @@ -10,7 +10,6 @@ let localport = 42379 let in_time_sum = ref 1.e-9 and in_size_sum = ref 0. - let () = let open Command_line in begin diff --git a/src/becke_numerical_grid/integration_radial.irp.f b/src/becke_numerical_grid/integration_radial.irp.f index c1add0cf..44c83070 100644 --- a/src/becke_numerical_grid/integration_radial.irp.f +++ b/src/becke_numerical_grid/integration_radial.irp.f @@ -64,7 +64,7 @@ enddo ! Ga-Kr - do i = 31, 36 + do i = 31, 100 alpha_knowles(i) = 7.d0 enddo diff --git a/src/bitmask/bitmasks.irp.f b/src/bitmask/bitmasks.irp.f index d425dda6..bbcff63c 100644 --- a/src/bitmask/bitmasks.irp.f +++ b/src/bitmask/bitmasks.irp.f @@ -11,7 +11,7 @@ BEGIN_PROVIDER [ integer, N_int ] if (N_int > N_int_max) then stop 'N_int > N_int_max' endif - + END_PROVIDER @@ -20,7 +20,7 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int) ] BEGIN_DOC ! Bitmask to include all possible MOs END_DOC - + integer :: i,j,k k=0 do j=1,N_int @@ -37,34 +37,34 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ] implicit none - integer :: i + integer :: i do i=1,N_int - 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,3) = full_ijkl_bitmask(i) - full_ijkl_bitmask_4(i,4) = 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,3) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i) enddo END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ] implicit none - integer :: i + integer :: i 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,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,4) = 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,3) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1) enddo END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ] implicit none - integer :: i + integer :: i do i=1,N_int - virt_bitmask_4(i,1) = 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,4) = 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,3) = virt_bitmask(i,1) + virt_bitmask_4(i,4) = virt_bitmask(i,1) enddo END_PROVIDER @@ -78,491 +78,480 @@ BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)] END_DOC integer :: i,j,n integer :: occ(elec_alpha_num) - + HF_bitmask = 0_bit_kind do i=1,elec_alpha_num - occ(i) = i + occ(i) = i enddo 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. call list_to_bitstring( HF_bitmask(1,2), occ, elec_beta_num, N_int) - + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask, (N_int,2)] - implicit none - BEGIN_DOC -! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask - END_DOC - ref_bitmask = HF_bitmask + implicit none + BEGIN_DOC + ! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask + END_DOC + ref_bitmask = HF_bitmask END_PROVIDER BEGIN_PROVIDER [ integer, N_generators_bitmask ] - implicit none - BEGIN_DOC - ! Number of bitmasks for generators - END_DOC - logical :: exists - PROVIDE ezfio_filename N_int - - if (mpi_master) then - call ezfio_has_bitmasks_N_mask_gen(exists) - if (exists) then - call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask) - integer :: N_int_check - integer :: bit_kind_check - call ezfio_get_bitmasks_bit_kind(bit_kind_check) - if (bit_kind_check /= bit_kind) then - print *, bit_kind_check, bit_kind - print *, 'Error: bit_kind is not correct in EZFIO file' + implicit none + BEGIN_DOC + ! Number of bitmasks for generators + END_DOC + logical :: exists + PROVIDE ezfio_filename N_int + + if (mpi_master) then + call ezfio_has_bitmasks_N_mask_gen(exists) + if (exists) then + call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask) + integer :: N_int_check + integer :: bit_kind_check + call ezfio_get_bitmasks_bit_kind(bit_kind_check) + if (bit_kind_check /= bit_kind) then + print *, bit_kind_check, bit_kind + 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 - 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 + ASSERT (N_generators_bitmask > 0) + call write_int(6,N_generators_bitmask,'N_generators_bitmask') endif - ASSERT (N_generators_bitmask > 0) - call write_int(6,N_generators_bitmask,'N_generators_bitmask') - endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( N_generators_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read N_generators_bitmask with MPI' - endif + include 'mpif.h' + integer :: ierr + call MPI_BCAST( N_generators_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read N_generators_bitmask with MPI' + endif IRP_ENDIF - - + + END_PROVIDER BEGIN_PROVIDER [ integer, N_generators_bitmask_restart ] - implicit none - BEGIN_DOC - ! Number of bitmasks for generators - END_DOC - logical :: exists - PROVIDE ezfio_filename N_int - - if (mpi_master) then - call ezfio_has_bitmasks_N_mask_gen(exists) - if (exists) then - call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask_restart) - integer :: N_int_check - integer :: bit_kind_check - call ezfio_get_bitmasks_bit_kind(bit_kind_check) - if (bit_kind_check /= bit_kind) then - print *, bit_kind_check, bit_kind - print *, 'Error: bit_kind is not correct in EZFIO file' + implicit none + BEGIN_DOC + ! Number of bitmasks for generators + END_DOC + logical :: exists + PROVIDE ezfio_filename N_int + + if (mpi_master) then + call ezfio_has_bitmasks_N_mask_gen(exists) + if (exists) then + call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask_restart) + integer :: N_int_check + integer :: bit_kind_check + call ezfio_get_bitmasks_bit_kind(bit_kind_check) + if (bit_kind_check /= bit_kind) then + print *, bit_kind_check, bit_kind + 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 - 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 + ASSERT (N_generators_bitmask_restart > 0) + call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart') endif - ASSERT (N_generators_bitmask_restart > 0) - call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart') - endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( N_generators_bitmask_restart, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read N_generators_bitmask_restart with MPI' - endif - IRP_ENDIF - - + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( N_generators_bitmask_restart, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read N_generators_bitmask_restart with MPI' + endif + IRP_ENDIF + + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_generators_bitmask_restart) ] - implicit none - BEGIN_DOC - ! Bitmasks for generator determinants. - ! (N_int, alpha/beta, hole/particle, generator). - ! - ! 3rd index is : - ! - ! * 1 : hole for single exc - ! - ! * 2 : particle for single exc - ! - ! * 3 : hole for 1st exc of double - ! - ! * 4 : particle for 1st exc of double - ! - ! * 5 : hole for 2nd exc of double - ! - ! * 6 : particle for 2nd exc of double - ! - END_DOC - logical :: exists - PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask N_int - PROVIDE generators_bitmask_restart - - if (mpi_master) then - call ezfio_has_bitmasks_generators(exists) - if (exists) then - call ezfio_get_bitmasks_generators(generators_bitmask_restart) - else - integer :: k, ispin + implicit none + BEGIN_DOC + ! Bitmasks for generator determinants. + ! (N_int, alpha/beta, hole/particle, generator). + ! + ! 3rd index is : + ! + ! * 1 : hole for single exc + ! + ! * 2 : particle for single exc + ! + ! * 3 : hole for 1st exc of double + ! + ! * 4 : particle for 1st exc of double + ! + ! * 5 : hole for 2nd exc of double + ! + ! * 6 : particle for 2nd exc of double + ! + END_DOC + logical :: exists + PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask N_int + PROVIDE generators_bitmask_restart + + if (mpi_master) then + call ezfio_has_bitmasks_generators(exists) + if (exists) then + call ezfio_get_bitmasks_generators(generators_bitmask_restart) + else + 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 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) + 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 - - 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 - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: 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 - stop 'Unable to read generators_bitmask_restart with MPI' - endif + include 'mpif.h' + integer :: 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 + stop 'Unable to read generators_bitmask_restart with MPI' + endif IRP_ENDIF - + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_bitmask) ] - implicit none - BEGIN_DOC - ! Bitmasks for generator determinants. - ! (N_int, alpha/beta, hole/particle, generator). - ! - ! 3rd index is : - ! - ! * 1 : hole for single exc - ! - ! * 2 : particle for single exc - ! - ! * 3 : hole for 1st exc of double - ! - ! * 4 : particle for 1st exc of double - ! - ! * 5 : hole for 2nd exc of double - ! - ! * 6 : particle for 2nd exc of double - ! - END_DOC - logical :: exists - PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask - -if (mpi_master) then - call ezfio_has_bitmasks_generators(exists) - if (exists) then - call ezfio_get_bitmasks_generators(generators_bitmask) - else - integer :: k, ispin, i - do k=1,N_generators_bitmask - do ispin=1,2 - do i=1,N_int - 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,d_hole1,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_part2,k) = full_ijkl_bitmask(i) + implicit none + BEGIN_DOC + ! Bitmasks for generator determinants. + ! (N_int, alpha/beta, hole/particle, generator). + ! + ! 3rd index is : + ! + ! * 1 : hole for single exc + ! + ! * 2 : particle for single exc + ! + ! * 3 : hole for 1st exc of double + ! + ! * 4 : particle for 1st exc of double + ! + ! * 5 : hole for 2nd exc of double + ! + ! * 6 : particle for 2nd exc of double + ! + END_DOC + logical :: exists + PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask + + if (mpi_master) then + call ezfio_has_bitmasks_generators(exists) + if (exists) then + call ezfio_get_bitmasks_generators(generators_bitmask) + else + integer :: k, ispin, i + do k=1,N_generators_bitmask + do ispin=1,2 + do i=1,N_int + 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,d_hole1,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_part2,k) = full_ijkl_bitmask(i) + enddo + enddo enddo - enddo - enddo - endif - - do k=1,N_generators_bitmask - do ispin=1,2 - do i=1,N_int - generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,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_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,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_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) ) - generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) ) - enddo - enddo - enddo - endif + endif + + do k=1,N_generators_bitmask + do ispin=1,2 + do i=1,N_int + generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,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_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,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_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) ) + generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) ) + enddo + enddo + enddo + endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: 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 - stop 'Unable to read generators_bitmask with MPI' - endif + include 'mpif.h' + integer :: 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 + stop 'Unable to read generators_bitmask with MPI' + endif IRP_ENDIF - + END_PROVIDER BEGIN_PROVIDER [ integer, N_cas_bitmask ] - implicit none - BEGIN_DOC - ! Number of bitmasks for CAS - END_DOC - logical :: exists - PROVIDE ezfio_filename - PROVIDE N_cas_bitmask N_int - if (mpi_master) then - call ezfio_has_bitmasks_N_mask_cas(exists) - if (exists) then - call ezfio_get_bitmasks_N_mask_cas(N_cas_bitmask) - integer :: N_int_check - integer :: bit_kind_check - call ezfio_get_bitmasks_bit_kind(bit_kind_check) - if (bit_kind_check /= bit_kind) then - print *, bit_kind_check, bit_kind - print *, 'Error: bit_kind is not correct in EZFIO file' + implicit none + BEGIN_DOC + ! Number of bitmasks for CAS + END_DOC + logical :: exists + PROVIDE ezfio_filename + PROVIDE N_cas_bitmask N_int + if (mpi_master) then + call ezfio_has_bitmasks_N_mask_cas(exists) + if (exists) then + call ezfio_get_bitmasks_N_mask_cas(N_cas_bitmask) + integer :: N_int_check + integer :: bit_kind_check + call ezfio_get_bitmasks_bit_kind(bit_kind_check) + if (bit_kind_check /= bit_kind) then + print *, bit_kind_check, bit_kind + 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 - 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 + call write_int(6,N_cas_bitmask,'N_cas_bitmask') endif - call write_int(6,N_cas_bitmask,'N_cas_bitmask') - endif - ASSERT (N_cas_bitmask > 0) + ASSERT (N_cas_bitmask > 0) IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( N_cas_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read N_cas_bitmask with MPI' - endif + include 'mpif.h' + integer :: ierr + call MPI_BCAST( N_cas_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read N_cas_bitmask with MPI' + endif IRP_ENDIF - + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ] - implicit none - BEGIN_DOC - ! Bitmasks for CAS reference determinants. (N_int, alpha/beta, CAS reference) - END_DOC - logical :: exists - integer :: i,i_part,i_gen,j,k - PROVIDE ezfio_filename generators_bitmask_restart full_ijkl_bitmask - PROVIDE n_generators_bitmask HF_bitmask - - if (mpi_master) then - call ezfio_has_bitmasks_cas(exists) - if (exists) then - 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 + implicit none + BEGIN_DOC + ! Bitmasks for CAS reference determinants. (N_int, alpha/beta, CAS reference) + END_DOC + logical :: exists + integer :: i,i_part,i_gen,j,k + PROVIDE ezfio_filename generators_bitmask_restart full_ijkl_bitmask + PROVIDE n_generators_bitmask HF_bitmask + + if (mpi_master) then + call ezfio_has_bitmasks_cas(exists) + if (exists) then + call ezfio_get_bitmasks_cas(cas_bitmask) 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 + 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 + 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 - do i=1,N_cas_bitmask - do j = 1, N_cas_bitmask - do k=1,N_int - cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k)) + do i=1,N_cas_bitmask + do j = 1, N_cas_bitmask + do k=1,N_int + cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k)) + enddo enddo enddo - enddo - write(*,*) 'Read CAS bitmask' - endif + write(*,*) 'Read CAS bitmask' + endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: 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 - stop 'Unable to read cas_bitmask with MPI' - endif + include 'mpif.h' + integer :: 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 + stop 'Unable to read cas_bitmask with MPI' + endif IRP_ENDIF - - + + END_PROVIDER - BEGIN_PROVIDER [ integer, n_core_inact_orb ] - implicit none - integer :: i - n_core_inact_orb = 0 - do i = 1, N_int - n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1)) - enddo - ENd_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] - implicit none - 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_bitmask, (N_int,2)] + implicit none + 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)] - implicit none - BEGIN_DOC - ! Reunion of the core, inactive and active bitmasks - END_DOC - integer :: i,j - - 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_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2)) - enddo - END_PROVIDER +BEGIN_PROVIDER [integer(bit_kind), reunion_of_inact_act_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the inactive and active bitmasks + END_DOC + integer :: i,j + + do i = 1, N_int + reunion_of_inact_act_bitmask(i,1) = ior(inact_bitmask(i,1),act_bitmask(i,1)) + reunion_of_inact_act_bitmask(i,2) = ior(inact_bitmask(i,2),act_bitmask(i,2)) + 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), reunion_of_core_inact_act_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the core, inactive and active bitmasks + END_DOC + integer :: i,j + + 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_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2)) + 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), core_inact_virt_bitmask, (N_int,2)] - implicit none - BEGIN_DOC - ! Reunion of the inactive and virtual bitmasks - END_DOC - integer :: i,j - do i = 1, N_int - 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)) - 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)) - enddo - END_PROVIDER + implicit none + BEGIN_DOC + ! Reunion of the inactive and virtual bitmasks + END_DOC + integer :: i,j + do i = 1, N_int + 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)) + 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)) + enddo +END_PROVIDER BEGIN_PROVIDER [ integer, i_bitmask_gen ] - implicit none - BEGIN_DOC - ! Current bitmask for the generators - END_DOC - i_bitmask_gen = 1 + implicit none + BEGIN_DOC + ! Current bitmask for the generators + END_DOC + i_bitmask_gen = 1 END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)] - implicit none - BEGIN_DOC - ! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask - END_DOC - integer :: i - unpaired_alpha_electrons = 0_bit_kind - do i = 1, N_int - unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2)) - enddo - END_PROVIDER +BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)] + implicit none + BEGIN_DOC + ! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask + END_DOC + integer :: i + unpaired_alpha_electrons = 0_bit_kind + do i = 1, N_int + unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2)) + enddo +END_PROVIDER - BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] - implicit none - integer :: i,j - 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,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1)) - enddo - END_PROVIDER +BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] + implicit none + integer :: i,j + 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,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1)) + enddo +END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_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_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)) - enddo - 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 +BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_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_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)) + enddo +END_PROVIDER diff --git a/src/bitmask/bitmasks_routines.irp.f b/src/bitmask/bitmasks_routines.irp.f index 378a3dcd..5c4bf347 100644 --- a/src/bitmask/bitmasks_routines.irp.f +++ b/src/bitmask/bitmasks_routines.irp.f @@ -33,7 +33,7 @@ subroutine bitstring_to_list( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the inidices(+1) of the bits set to 1 in the bit string + ! Gives the indices(+1) of the bits set to 1 in the bit string END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: string(Nint) @@ -213,3 +213,34 @@ subroutine print_spindet(string,Nint) print *, trim(output(1)) end + +logical function is_integer_in_string(bite,string,Nint) + use bitmasks + implicit none + integer, intent(in) :: bite,Nint + integer(bit_kind), intent(in) :: string(Nint) + integer(bit_kind) :: string_bite(Nint) + integer :: i,itot,itot_and + character*(2048) :: output(1) + string_bite = 0_bit_kind + call set_bit_to_integer(bite,string_bite,Nint) + itot = 0 + itot_and = 0 + is_integer_in_string = .False. +!print*,'' +!print*,'' +!print*,'bite = ',bite +!call bitstring_to_str( output(1), string_bite, Nint ) +! print *, trim(output(1)) +!call bitstring_to_str( output(1), string, Nint ) +! print *, trim(output(1)) + do i = 1, Nint + itot += popcnt(string(i)) + itot_and += popcnt(ior(string(i),string_bite(i))) + enddo +!print*,'itot,itot_and',itot,itot_and + if(itot == itot_and)then + is_integer_in_string = .True. + endif +!pause +end diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index f830da4e..b016f1fd 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -1,246 +1,383 @@ 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_act_orb] - &BEGIN_PROVIDER [ integer, n_virt_orb ] - &BEGIN_PROVIDER [ integer, n_del_orb ] - 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 +BEGIN_PROVIDER [ integer, n_inact_orb ] + implicit none + BEGIN_DOC + ! Number of inactive MOs + END_DOC + integer :: i + + n_inact_orb = 0 + do i = 1, mo_num + if (mo_class(i) == 'Inactive')then + n_inact_orb += 1 + endif + enddo + + call write_int(6,n_inact_orb,'Number of inactive MOs') + +END_PROVIDER - n_core_orb = 0 - n_inact_orb = 0 - n_act_orb = 0 - n_virt_orb = 0 - n_del_orb = 0 - do i = 1, mo_num - if(mo_class(i) == 'Core')then - n_core_orb += 1 - else if (mo_class(i) == 'Inactive')then - n_inact_orb += 1 - else if (mo_class(i) == 'Active')then - n_act_orb += 1 - else if (mo_class(i) == 'Virtual')then - n_virt_orb += 1 - else if (mo_class(i) == 'Deleted')then - n_del_orb += 1 - endif - enddo +BEGIN_PROVIDER [ integer, n_act_orb] + implicit none + BEGIN_DOC + ! Number of active MOs + END_DOC + integer :: i + + n_act_orb = 0 + do i = 1, mo_num + if (mo_class(i) == 'Active')then + n_act_orb += 1 + endif + enddo + + call write_int(6,n_act_orb, 'Number of active MOs') + +END_PROVIDER + +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') - call write_int(6,n_inact_orb,'Number of inactive MOs') - call write_int(6,n_act_orb, 'Number of active MOs') - call write_int(6,n_virt_orb, 'Number of virtual MOs') - call write_int(6,n_del_orb, 'Number of deleted MOs') - - END_PROVIDER - - - BEGIN_PROVIDER [integer, dim_list_core_orb] -&BEGIN_PROVIDER [integer, dim_list_inact_orb] -&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 - 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_core_inact_orb ] + implicit none + BEGIN_DOC + ! n_core + n_inact + END_DOC + integer :: i + n_core_inact_orb = 0 + do i = 1, N_int + n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1)) + enddo +END_PROVIDER BEGIN_PROVIDER [integer, n_inact_act_orb ] - implicit none - n_inact_act_orb = (n_inact_orb+n_act_orb) + implicit none + 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)] - integer :: i,itmp - itmp = 0 - do i = 1, n_inact_orb - itmp += 1 - list_inact_act(itmp) = list_inact(i) - enddo - do i = 1, n_act_orb - itmp += 1 - list_inact_act(itmp) = list_act(i) - enddo -END_PROVIDER +BEGIN_PROVIDER [integer, dim_list_act_orb] + implicit none + BEGIN_DOC + ! dimensions for the allocation of list_act. + ! it is at least 1 + END_DOC + dim_list_act_orb = max(n_act_orb,1) +END_PROVIDER + +BEGIN_PROVIDER [integer, dim_list_virt_orb] + implicit none + 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 ] - implicit none - n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb) + implicit none + 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)] - integer :: i,itmp - itmp = 0 - do i = 1, n_core_orb - itmp += 1 - list_core_inact_act(itmp) = list_core(i) - enddo - do i = 1, n_inact_orb - itmp += 1 - 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 + + 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 + ! Bitmask identifying the core/inactive/active/virtual/deleted MOs + END_DOC - integer :: occ_inact(N_int*bit_kind_size) - occ_inact = 0 - call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int) - list_inact_reverse = 0 - do i = 1, n_core_inact_act_orb - list_core_inact_act_reverse(occ_inact(i)) = i - enddo -END_PROVIDER + core_bitmask = 0_bit_kind + inact_bitmask = 0_bit_kind + act_bitmask = 0_bit_kind + virt_bitmask = 0_bit_kind + del_bitmask = 0_bit_kind + + if(n_core_orb > 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 > 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) + print*, list_act_reverse(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 + diff --git a/src/casscf/EZFIO.cfg b/src/casscf/EZFIO.cfg new file mode 100644 index 00000000..ce51a064 --- /dev/null +++ b/src/casscf/EZFIO.cfg @@ -0,0 +1,19 @@ +[energy] +type: double precision +doc: Calculated Selected |FCI| energy +interface: ezfio +size: (determinants.n_states) + +[energy_pt2] +type: double precision +doc: Calculated |FCI| energy + |PT2| +interface: ezfio +size: (determinants.n_states) + +[cisd_guess] +type: logical +doc: If true, the CASSCF starts with a CISD wave function +interface: ezfio,provider,ocaml +default: True + + diff --git a/src/casscf/NEED b/src/casscf/NEED new file mode 100644 index 00000000..b992ff71 --- /dev/null +++ b/src/casscf/NEED @@ -0,0 +1,4 @@ +cipsi +selectors_full +generators_fluid +two_body_rdm diff --git a/src/casscf/README.rst b/src/casscf/README.rst new file mode 100644 index 00000000..08bfd95b --- /dev/null +++ b/src/casscf/README.rst @@ -0,0 +1,5 @@ +====== +casscf +====== + +|CASSCF| program with the CIPSI algorithm. diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f new file mode 100644 index 00000000..402e67ec --- /dev/null +++ b/src/casscf/bavard.irp.f @@ -0,0 +1,6 @@ +! -*- F90 -*- +BEGIN_PROVIDER [logical, bavard] +! bavard=.true. + bavard=.false. +END_PROVIDER + diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f new file mode 100644 index 00000000..0a44f994 --- /dev/null +++ b/src/casscf/bielec.irp.f @@ -0,0 +1,155 @@ +BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)] + BEGIN_DOC + ! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + real*8 :: mo_two_e_integral + + bielec_PQxx(:,:,:,:) = 0.d0 + PROVIDE mo_two_e_integrals_in_map + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,ii,j,jj,i3,j3) & + !$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PQxx, & + !$OMP n_act_orb,mo_integrals_map,list_act) + + !$OMP DO + do i=1,n_core_inact_orb + ii=list_core_inact(i) + do j=i,n_core_inact_orb + jj=list_core_inact(j) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j),mo_integrals_map) + bielec_PQxx(:,:,j,i)=bielec_PQxx(:,:,i,j) + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_inact_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j3),mo_integrals_map) + bielec_PQxx(:,:,j3,i)=bielec_PQxx(:,:,i,j3) + end do + end do + !$OMP END DO + + + !$OMP DO + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_inact_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_inact_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i3,j3),mo_integrals_map) + bielec_PQxx(:,:,j3,i3)=bielec_PQxx(:,:,i3,j3) + end do + end do + !$OMP END DO + + !$OMP END PARALLEL + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)] + BEGIN_DOC + ! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + double precision, allocatable :: integrals_array(:,:) + 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)) + + !$OMP DO + do i=1,n_core_inact_orb + ii=list_core_inact(i) + do j=i,n_core_inact_orb + jj=list_core_inact(j) + 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 + bielec_PxxQ(p,i,j,q)=integrals_array(p,q) + bielec_PxxQ(p,j,i,q)=integrals_array(q,p) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_inact_orb + 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 + bielec_PxxQ(p,i,j3,q)=integrals_array(p,q) + bielec_PxxQ(p,j3,i,q)=integrals_array(q,p) + end do + end do + end do + end do + !$OMP END DO + + + ! (ip|qj) + !$OMP DO + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_inact_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_inact_orb + 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 + bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q) + bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p) + end do + end do + end do + end do + !$OMP END DO + + deallocate(integrals_array) + !$OMP END PARALLEL + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] + BEGIN_DOC + ! bielecCI : integrals (tu|vp) with p arbitrary, tuv active + ! index p runs over the whole basis, t,u,v only over the active orbitals + END_DOC + implicit none + integer :: i,j,k,p,t,u,v + double precision, external :: mo_two_e_integral + PROVIDE mo_two_e_integrals_in_map + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP PRIVATE(i,j,k,p,t,u,v) & + !$OMP SHARED(mo_num,n_act_orb,list_act,bielecCI) + do p=1,mo_num + do j=1,n_act_orb + u=list_act(j) + do k=1,n_act_orb + v=list_act(k) + do i=1,n_act_orb + t=list_act(i) + bielecCI(i,k,j,p) = mo_two_e_integral(t,u,v,p) + end do + end do + end do + end do + !$OMP END PARALLEL DO + +END_PROVIDER diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f new file mode 100644 index 00000000..9968530c --- /dev/null +++ b/src/casscf/bielec_natorb.irp.f @@ -0,0 +1,369 @@ + BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)] + BEGIN_DOC + ! integral (pq|xx) in the basis of natural MOs + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q + double precision, allocatable :: f(:,:,:), d(:,:,:) + + + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,p,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 + f(p,j,k)=bielec_PQxx_no(list_act(p),j,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, 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 + bielec_PQxx_no(list_act(p),j,k,l)=d(p,j,k) + end do + end do + + do j=1,mo_num + do p=1,n_act_orb + 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 + do j=1,mo_num + bielec_PQxx_no(j,list_act(p),k,l)=d(p,j,k) + end do + end do + end do + end do + !$OMP END DO NOWAIT + + deallocate (f,d) + + allocate (f(mo_num,mo_num,n_act_orb),d(mo_num,mo_num,n_act_orb)) + + !$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 + end do + call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, & + f, mo_num*mo_num, & + natorbsCI, n_act_orb, & + 0.d0, & + d, mo_num*mo_num) + do p=1,n_act_orb + do k=1,mo_num + do j=1,mo_num + bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(j,k,p) + end do + end do + end do + end do + !$OMP END DO NOWAIT + + !$OMP BARRIER + + !$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,l,n_core_inact_orb+p) + end do + end do + end do + call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, & + f, mo_num*mo_num, & + natorbsCI, n_act_orb, & + 0.d0, & + d, mo_num*mo_num) + do p=1,n_act_orb + do k=1,mo_num + do j=1,mo_num + bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(j,k,p) + end do + end do + end do + end do + !$OMP END DO + + deallocate (f,d) + !$OMP END PARALLEL + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)] + BEGIN_DOC + ! integral (px|xq) in the basis of natural MOs + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q + double precision, allocatable :: f(:,:,:), d(:,:,:) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,p,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 + bielec_PxxQ_no(:,:,:,j) = bielec_PxxQ(:,:,:,j) + do l=1,n_core_inact_act_orb + do k=1,n_core_inact_act_orb + do p=1,n_act_orb + f(p,k,l) = bielec_PxxQ_no(list_act(p),k,l,j) + 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 + bielec_PxxQ_no(list_act(p),k,l,j)=d(p,k,l) + end do + end do + end do + end do + !$OMP END DO NOWAIT + + deallocate (f,d) + + 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 + f(p,j,l) = bielec_PxxQ_no(j,n_core_inact_orb+p,l,k) + 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 + bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(p,j,l) + end do + end do + end do + end do + !$OMP END DO NOWAIT + + deallocate(f,d) + + allocate(f(mo_num,n_core_inact_act_orb,n_act_orb), & + 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 + end do + call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, & + f, mo_num*n_core_inact_act_orb, & + natorbsCI, size(natorbsCI,1), & + 0.d0, & + d, mo_num*n_core_inact_act_orb) + do p=1,n_act_orb + 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,p) + end do + end do + end do + end do + !$OMP END DO NOWAIT + + !$OMP BARRIER + + !$OMP DO + 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 + end do + call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, & + f, mo_num*n_core_inact_act_orb, & + natorbsCI, size(natorbsCI,1), & + 0.d0, & + d, mo_num*n_core_inact_act_orb) + do p=1,n_act_orb + 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,p) + end do + end do + end do + end do + !$OMP END DO NOWAIT + deallocate(f,d) + !$OMP END PARALLEL + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] + BEGIN_DOC + ! integrals (tu|vp) in the basis of natural MOs + ! index p runs over the whole basis, t,u,v only over the active orbitals + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q + double precision, allocatable :: f(:,:,:), d(:,:,:) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,p,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) + + 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 j=1,n_act_orb + do p=1,n_act_orb + f(p,j,k)=bielecCI_no(p,j,k,l) + end do + end do + end do + call dgemm('T','N',n_act_orb,n_act_orb*n_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_act_orb + do j=1,n_act_orb + do p=1,n_act_orb + bielecCI_no(p,j,k,l)=d(p,j,k) + end do + end do + + do j=1,n_act_orb + do p=1,n_act_orb + f(p,j,k)=bielecCI_no(j,p,k,l) + end do + end do + end do + call dgemm('T','N',n_act_orb,n_act_orb*n_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_act_orb + do p=1,n_act_orb + do j=1,n_act_orb + bielecCI_no(j,p,k,l)=d(p,j,k) + end do + end do + end do + + do p=1,n_act_orb + 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 + 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 + do k=1,n_act_orb + do j=1,n_act_orb + bielecCI_no(j,k,p,l)=d(j,k,p) + end do + end do + end do + end do + !$OMP END DO + + !$OMP DO + do l=1,n_act_orb + do p=1,n_act_orb + 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 + 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 + do k=1,n_act_orb + do j=1,n_act_orb + bielecCI_no(j,k,l,list_act(p))=d(j,k,p) + end do + end do + end do + end do + !$OMP END DO + + deallocate(d,f) + !$OMP END PARALLEL + + +END_PROVIDER + diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f new file mode 100644 index 00000000..8b5a365f --- /dev/null +++ b/src/casscf/casscf.irp.f @@ -0,0 +1,124 @@ +program casscf + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + threshold_davidson = 1.d-7 + touch threshold_davidson + if(cisd_guess)then + logical :: converged + integer :: iteration + double precision :: energy + print*,'*******************************' + print*,'*******************************' + print*,'*******************************' + print*,'USING A CISD WAVE FUNCTION AS GUESS FOR THE MCSCF WF' + print*,'*******************************' + print*,'*******************************' + converged = .False. + iteration = 0 + generators_type = "HF" + touch generators_type + read_wf = .False. + touch read_wf + logical :: do_cisdtq + do_cisdtq = .True. + double precision :: thr + thr = 5.d-3 + do while (.not.converged) + call cisd_scf_iteration(converged,iteration,energy,thr) + if(HF_index.ne.1.and.iteration.gt.0)then + print*,'*******************************' + print*,'*******************************' + print*,'The HF determinant is not the dominant determinant in the CISD WF ...' + print*,'Therefore we skip the CISD WF ..' + print*,'*******************************' + print*,'*******************************' + do_cisdtq = .False. + exit + endif + if(iteration.gt.15.and..not.converged)then + print*,'It seems that the orbital optimization for the CISD WAVE FUNCTION CANNOT CONVERGE ...' + print*,'Passing to CISDTQ WAVE FUNCTION' + exit + endif + enddo + if(do_cisdtq)then + print*,'*******************************' + print*,'*******************************' + print*,'*******************************' + print*,'SWITCHING WITH A CISDTQ WAVE FUNCTION AS GUESS FOR THE MCSCF WF' + print*,'*******************************' + print*,'*******************************' + converged = .False. + iteration = 0 + read_wf = .False. + touch read_wf + pt2_max = 0.01d0 + touch pt2_max + energy = 0.d0 + do while (.not.converged) + call cisdtq_scf_iteration(converged,iteration,energy,thr) + if(HF_index.ne.1.and.iteration.gt.0)then + print*,'*******************************' + print*,'*******************************' + print*,'The HF determinant is not the dominant determinant in the CISDTQ WF ...' + print*,'Therefore we skip the CISDTQ WF ..' + print*,'*******************************' + print*,'*******************************' + exit + endif + if(iteration.gt.15.and..not.converged)then + print*,'It seems that the orbital optimization for the CISDTQ WAVE FUNCTION CANNOT CONVERGE ...' + print*,'Passing to CISDTQ WAVE FUNCTION' + exit + endif + enddo + endif + endif + read_wf = .False. + touch read_wf + pt2_max = 0.0d0 + touch pt2_max +! call run_cipsi_scf + call run +end + +subroutine run + implicit none + double precision :: energy_old, energy + logical :: converged + integer :: iteration + converged = .False. + + energy = 0.d0 + mo_label = "MCSCF" + iteration = 1 + do while (.not.converged) + call run_stochastic_cipsi + energy_old = energy + energy = eone+etwo+ecore + + call write_time(6) + call write_int(6,iteration,'CAS-SCF iteration') + call write_double(6,energy,'CAS-SCF energy') + call write_double(6,energy_improvement, 'Predicted energy improvement') + + converged = dabs(energy_improvement) < thresh_scf +! pt2_max = dabs(energy_improvement / pt2_relative_error) + + mo_coef = NewOrbs + call save_mos + iteration += 1 + N_det = N_det/2 + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + read_wf = .True. + call clear_mo_map + SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef + + enddo + +end diff --git a/src/casscf/change_bitmasks.irp.f b/src/casscf/change_bitmasks.irp.f new file mode 100644 index 00000000..cad6ec38 --- /dev/null +++ b/src/casscf/change_bitmasks.irp.f @@ -0,0 +1,14 @@ +subroutine only_act_bitmask + implicit none + integer :: i,j,k + do k = 1, N_generators_bitmask + do j = 1, 6 + do i = 1, N_int + generators_bitmask(i,1,j,k) = act_bitmask(i,1) + generators_bitmask(i,2,j,k) = act_bitmask(i,2) + enddo + enddo + enddo + touch generators_bitmask +end + diff --git a/src/casscf/cipsi_routines.irp.f b/src/casscf/cipsi_routines.irp.f new file mode 100644 index 00000000..272a7116 --- /dev/null +++ b/src/casscf/cipsi_routines.irp.f @@ -0,0 +1,75 @@ +subroutine run_cipsi_scf + implicit none + double precision :: energy_old, energy, extrap,extrap_old,pt2_max_begin + logical :: converged + integer :: iteration + print*,'*********************************' + print*,'*********************************' + print*,' DOING THE CIPSI-SCF ' + print*,'*********************************' + converged = .False. + pt2_max_begin = pt2_max + energy = 0.d0 + extrap = 0.d0 + mo_label = "MCSCF" + iteration = 1 + threshold_davidson = 1.d-09 + touch threshold_davidson + do while (.not.converged) + print*,'' + call write_int(6,iteration,'CI STEP OF THE ITERATION = ') + call write_double(6,pt2_max,'PT2 MAX = ') + !call cisd_guess_wf + generators_type = "CAS" + touch generators_type + call run_stochastic_cipsi + call change_orb_cipsi(converged,iteration,energy) + if(iteration.gt.n_it_scf_max.and..not.converged)then + print*,'It seems that the orbital optimization for the CISDTQ WAVE FUNCTION CANNOT CONVERGE ...' + print*,'The required delta E was :',thresh_scf + print*,'The obtained delta E was :',extrap - extrap_old + print*,'After ',iteration,'iterations ...' + print*,'Getting out of the SCF loop ...' + exit + endif + iteration += 1 + enddo + +end + +subroutine change_orb_cipsi(converged,iteration,energy) + implicit none + double precision :: energy_old, extrap,extrap_old,pt2_max_begin + double precision, intent(inout):: energy + logical, intent(out) :: converged + integer, intent(in) :: iteration + extrap_old = energy + energy = eone+etwo+ecore + extrap = extrapolated_energy(2,1) + + call write_time(6) + call write_int(6,iteration,'CAS-SCF iteration') + call write_double(6,energy,'CAS-SCF variational energy') + call write_double(6,extrap,'CAS-SCF extrapolated energy') + call write_double(6,extrap - extrap_old,'Change in extrapolated energy') + energy = extrap + call write_double(6,energy_improvement, 'Predicted energy improvement') + + converged = dabs(extrap - extrap_old) < thresh_scf + pt2_max = dabs(extrap - extrap_old) * 10.d0 + pt2_max = min(pt2_max,1.d-2) + pt2_max = max(pt2_max,1.d-10) + if(N_det.gt.10**6)then + pt2_max = max(pt2_max,1.d-2) + endif + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + N_det = N_det/2 + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + read_wf = .True. + FREE mo_integrals_map mo_two_e_integrals_in_map + SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef +end diff --git a/src/casscf/cisd_routine.irp.f b/src/casscf/cisd_routine.irp.f new file mode 100644 index 00000000..a4cbfcfb --- /dev/null +++ b/src/casscf/cisd_routine.irp.f @@ -0,0 +1,85 @@ +subroutine cisd_scf_iteration(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(out) :: converged + integer, intent(inout) :: iteration + double precision, intent(out) :: energy + converged = .False. + call only_act_bitmask + N_det = N_det_generators + psi_coef = psi_coef_generators + psi_det = psi_det_generators + touch N_det psi_coef psi_det + call run_cisd + call change_orb_cisd(converged,iteration,energy,thr) +end + + +subroutine cisd_guess_wf + implicit none + call only_act_bitmask + N_det = N_det_generators + psi_coef = psi_coef_generators + psi_det = psi_det_generators + touch N_det psi_coef psi_det + generators_type = "HF" + touch generators_type + call run_cisd + touch N_det psi_coef psi_det psi_coef_sorted psi_det_sorted psi_det_sorted_order psi_average_norm_contrib_sorted + +end + + + +subroutine change_orb_cisd(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(inout) :: converged + integer, intent(inout) :: iteration + double precision, intent(inout) :: energy + double precision :: energy_old + energy_old = energy + + energy = eone+etwo+ecore + + call write_time(6) + call write_int(6,iteration,'CISD-SCF iteration') + call write_double(6,energy,'CISD-SCF energy') + call write_double(6,energy_improvement, 'Predicted energy improvement') + converged = dabs(energy_improvement) < thr + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + FREE mo_integrals_map mo_two_e_integrals_in_map + iteration += 1 + +end + +subroutine run_cisd + implicit none + integer :: i + + if(pseudo_sym)then + call H_apply_cisd_sym + else + call H_apply_cisd + endif + print *, 'N_det = ', N_det + print*,'******************************' + print *, 'Energies of the states:' + do i = 1,N_states + print *, i, CI_energy(i) + enddo + if (N_states > 1) then + print*,'******************************' + print*,'Excitation energies ' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1) + enddo + endif + psi_coef = ci_eigenvectors + SOFT_TOUCH psi_coef + call save_wavefunction + +end diff --git a/src/casscf/cisdtq_routine.irp.f b/src/casscf/cisdtq_routine.irp.f new file mode 100644 index 00000000..0479d462 --- /dev/null +++ b/src/casscf/cisdtq_routine.irp.f @@ -0,0 +1,47 @@ +subroutine cisdtq_scf_iteration(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(out) :: converged + integer, intent(inout) :: iteration + double precision, intent(inout) :: energy + converged = .False. + call only_act_bitmask + generators_type = "HF_SD" + threshold_generators = 0.99d0 + touch threshold_generators + touch generators_type + selection_factor = 5 + touch selection_factor + call run_stochastic_cipsi + call change_orb_cisdtq(converged,iteration,energy,thr) +end + +subroutine change_orb_cisdtq(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(inout) :: converged + integer, intent(inout) :: iteration + double precision, intent(inout) :: energy + double precision :: extrap,extrap_old,pt2_max_begin + extrap_old = energy + extrap = extrapolated_energy(2,1) + energy = extrap + + call write_time(6) + call write_int(6,iteration,'CISDTQ-SCF iteration') + call write_double(6,energy,'CISDTQ-SCF variational energy') + call write_double(6,extrap,'CISDTQ-SCF extrapolated energy') + call write_double(6,extrap - extrap_old,'Change in extrapolated energy') + + converged = dabs(extrap - extrap_old) < thr + pt2_max = dabs(extrap - extrap_old) * 10.d0 + pt2_max = max(pt2_max,1.d-10) + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + FREE mo_integrals_map mo_two_e_integrals_in_map + iteration += 1 + +end + diff --git a/src/casscf/class.irp.f b/src/casscf/class.irp.f new file mode 100644 index 00000000..7360a661 --- /dev/null +++ b/src/casscf/class.irp.f @@ -0,0 +1,12 @@ + BEGIN_PROVIDER [ logical, do_only_1h1p ] +&BEGIN_PROVIDER [ logical, do_only_cas ] +&BEGIN_PROVIDER [ logical, do_ddci ] + implicit none + BEGIN_DOC + ! In the CAS case, all those are always false except do_only_cas + END_DOC + do_only_cas = .True. + do_only_1h1p = .False. + do_ddci = .False. +END_PROVIDER + diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f new file mode 100644 index 00000000..292067b4 --- /dev/null +++ b/src/casscf/densities.irp.f @@ -0,0 +1,67 @@ +use bitmasks + +BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] + implicit none + BEGIN_DOC + ! the first-order density matrix in the basis of the starting MOs. + ! matrix is state averaged. + END_DOC + integer :: t,u + + do u=1,n_act_orb + do t=1,n_act_orb + D0tu(t,u) = one_e_dm_mo_alpha_average( list_act(t), list_act(u) ) + & + one_e_dm_mo_beta_average ( list_act(t), list_act(u) ) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] + BEGIN_DOC + ! The second-order density matrix in the basis of the starting MOs ONLY IN THE RANGE OF ACTIVE MOS + ! The values are state averaged + ! + ! We use the spin-free generators of mono-excitations + ! E_pq destroys q and creates p + ! D_pq = <0|E_pq|0> = D_qp + ! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0> + ! + ! P0tuvx(p,q,r,s) = chemist notation : 1/2 <0|E_pq E_rs - delta_qr E_ps|0> + END_DOC + implicit none + integer :: t,u,v,x + integer :: tt,uu,vv,xx + integer :: mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: ierr + real*8 :: phase1,phase11,phase12,phase2,phase21,phase22 + integer :: nu1,nu2,nu11,nu12,nu21,nu22 + integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22 + real*8 :: cI_mu(N_states),term + integer(bit_kind), dimension(N_int,2) :: det_mu, det_mu_ex + integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12 + integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22 + + if (bavard) then + write(6,*) ' providing the 2 body RDM on the active part' + endif + + P0tuvx= 0.d0 + do istate=1,N_states + do x = 1, n_act_orb + xx = list_act(x) + do v = 1, n_act_orb + vv = list_act(v) + do u = 1, n_act_orb + uu = list_act(u) + do t = 1, n_act_orb + tt = list_act(t) +! P0tuvx(t,u,v,x) = state_av_act_two_rdm_openmp_spin_trace_mo(t,v,u,x) + P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x) + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f new file mode 100644 index 00000000..d8c309a4 --- /dev/null +++ b/src/casscf/det_manip.irp.f @@ -0,0 +1,125 @@ +use bitmasks + +subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & + ispin,phase,ierr) + BEGIN_DOC + ! we create the mono-excitation, and determine, if possible, + ! the phase and the number in the list of determinants + END_DOC + implicit none + integer(bit_kind) :: key1(N_int,2),key2(N_int,2) + integer(bit_kind), allocatable :: keytmp(:,:) + integer :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin + real*8 :: phase + logical :: found + allocate(keytmp(N_int,2)) + + nu=-1 + phase=1.D0 + ierr=0 + call det_copy(key1,key2,N_int) + ! write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin + ! call print_det(key2,N_int) + call do_single_excitation(key2,ihole,ipart,ispin,ierr) + ! write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin + ! call print_det(key2,N_int) + ! write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr + if (ierr.eq.1) then + ! excitation is possible + ! get the phase + call get_single_excitation(key1,key2,exc,phase,N_int) + ! get the number in the list + found=.false. + nu=0 + + !TODO BOTTLENECK + do while (.not.found) + nu+=1 + if (nu.gt.N_det) then + ! the determinant is possible, but not in the list + found=.true. + nu=-1 + else + call det_extract(keytmp,nu,N_int) + integer :: i,ii + found=.true. + do ii=1,2 + do i=1,N_int + if (keytmp(i,ii).ne.key2(i,ii)) then + found=.false. + end if + end do + end do + end if + end do + end if + ! + ! we found the new string, the phase, and possibly the number in the list + ! +end subroutine do_signed_mono_excitation + +subroutine det_extract(key,nu,Nint) + BEGIN_DOC + ! extract a determinant from the list of determinants + END_DOC + implicit none + integer :: ispin,i,nu,Nint + integer(bit_kind) :: key(Nint,2) + do ispin=1,2 + do i=1,Nint + key(i,ispin)=psi_det(i,ispin,nu) + end do + end do +end subroutine det_extract + +subroutine det_copy(key1,key2,Nint) + use bitmasks ! you need to include the bitmasks_module.f90 features + BEGIN_DOC + ! copy a determinant from key1 to key2 + END_DOC + implicit none + integer :: ispin,i,Nint + integer(bit_kind) :: key1(Nint,2),key2(Nint,2) + do ispin=1,2 + do i=1,Nint + key2(i,ispin)=key1(i,ispin) + end do + end do +end subroutine det_copy + +subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2 & + ,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr) + BEGIN_DOC + ! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q) + ! we may create two determinants as result + ! + END_DOC + implicit none + integer(bit_kind) :: key_in(N_int,2),key_out1(N_int,2) + integer(bit_kind) :: key_out2(N_int,2) + integer :: ihole,ipart,ierr,jerr,nu1,nu2 + integer :: ispin + real*8 :: phase1,phase2 + + ! write(6,*) ' applying E_',ipart,ihole,' on determinant ' + ! call print_det(key_in,N_int) + + ! spin alpha + ispin=1 + call do_signed_mono_excitation(key_in,key_out1,nu1,ihole & + ,ipart,ispin,phase1,ierr) + ! if (ierr.eq.1) then + ! write(6,*) ' 1 result is ',nu1,phase1 + ! call print_det(key_out1,N_int) + ! end if + ! spin beta + ispin=2 + call do_signed_mono_excitation(key_in,key_out2,nu2,ihole & + ,ipart,ispin,phase2,jerr) + ! if (jerr.eq.1) then + ! write(6,*) ' 2 result is ',nu2,phase2 + ! call print_det(key_out2,N_int) + ! end if + +end subroutine do_spinfree_mono_excitation + diff --git a/src/casscf/driver_optorb.irp.f b/src/casscf/driver_optorb.irp.f new file mode 100644 index 00000000..2e3e02dc --- /dev/null +++ b/src/casscf/driver_optorb.irp.f @@ -0,0 +1,3 @@ +subroutine driver_optorb + implicit none +end diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f new file mode 100644 index 00000000..8dce87aa --- /dev/null +++ b/src/casscf/get_energy.irp.f @@ -0,0 +1,57 @@ +program print_2rdm + implicit none + BEGIN_DOC + ! get the active part of the bielectronic energy on a given wave function. + ! + ! useful to test the active part of the spin trace 2 rdms + END_DOC + no_vvvv_integrals = .True. + read_wf = .True. + touch read_wf no_vvvv_integrals + call routine +end + +subroutine routine + integer :: i,j,k,l + integer :: ii,jj,kk,ll + double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral + thr = 1.d-10 + + + 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_spin_trace_mo(ii,jj,kk,ll) * integral + enddo + enddo + enddo + enddo + 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 + + print *, psi_energy_with_nucl_rep +end diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f new file mode 100644 index 00000000..f00bc7c8 --- /dev/null +++ b/src/casscf/gradient.irp.f @@ -0,0 +1,246 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, nMonoEx ] + BEGIN_DOC + ! Number of single excitations + END_DOC + implicit none + nMonoEx=n_core_inact_orb*n_act_orb+n_core_inact_orb*n_virt_orb+n_act_orb*n_virt_orb +END_PROVIDER + + BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] +&BEGIN_PROVIDER [character*3, excit_class, (nMonoEx)] + BEGIN_DOC + ! a list of the orbitals involved in the excitation + END_DOC + + implicit none + integer :: i,t,a,ii,tt,aa,indx + indx=0 + do ii=1,n_core_inact_orb + i=list_core_inact(ii) + do tt=1,n_act_orb + t=list_act(tt) + indx+=1 + excit(1,indx)=i + excit(2,indx)=t + excit_class(indx)='c-a' + end do + end do + + do ii=1,n_core_inact_orb + i=list_core_inact(ii) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=i + excit(2,indx)=a + excit_class(indx)='c-v' + end do + end do + + do tt=1,n_act_orb + t=list_act(tt) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=t + excit(2,indx)=a + excit_class(indx)='a-v' + end do + end do + + if (bavard) then + write(6,*) ' Filled the table of the Monoexcitations ' + do indx=1,nMonoEx + write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' & + ,excit(2,indx),' ',excit_class(indx) + end do + end if + +END_PROVIDER + +BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)] + BEGIN_DOC + ! calculate the orbital gradient by hand, i.e. for + ! each determinant I we determine the string E_pq |I> (alpha and beta + ! separately) and generate + ! sum_I c_I is then the pq component of the orbital + ! gradient + ! E_pq = a^+_pa_q + a^+_Pa_Q + END_DOC + implicit none + integer :: ii,tt,aa,indx,ihole,ipart,istate + real*8 :: res + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + call calc_grad_elem(ihole,ipart,res) + gradvec(indx)=res + end do + + real*8 :: norm_grad + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec(indx)*gradvec(indx) + end do + norm_grad=sqrt(norm_grad) + if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + endif + + +END_PROVIDER + +subroutine calc_grad_elem(ihole,ipart,res) + BEGIN_DOC + ! eq 18 of Siegbahn et al, Physica Scripta 1980 + ! we calculate 2 , q=hole, p=particle + END_DOC + implicit none + integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:) + real*8 :: i_H_psi_array(N_states),phase + allocate(det_mu(N_int,2)) + allocate(det_mu_ex(N_int,2)) + + res=0.D0 + + do mu=1,n_det + ! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 + ! do the monoexcitation on it + call det_copy(det_mu,det_mu_ex,N_int) + call do_signed_mono_excitation(det_mu,det_mu_ex,nu & + ,ihole,ipart,ispin,phase,ierr) + if (ierr.eq.1) then + call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase + end do + end if + end do + end do + + ! state-averaged gradient + res*=2.D0/dble(N_states) + +end subroutine calc_grad_elem + +BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] + BEGIN_DOC + ! calculate the orbital gradient from density + ! matrices and integrals; Siegbahn et al, Phys Scr 1980 + ! eqs 14 a,b,c + END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: gradvec_it,gradvec_ia,gradvec_ta + real*8 :: norm_grad + + indx=0 + do i=1,n_core_inact_orb + do t=1,n_act_orb + indx+=1 + gradvec2(indx)=gradvec_it(i,t) + end do + end do + + do i=1,n_core_inact_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ia(i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ta(t,a) + end do + end do + + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec2(indx)*gradvec2(indx) + end do + norm_grad=sqrt(norm_grad) +! if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) +! endif + +END_PROVIDER + +real*8 function gradvec_it(i,t) + BEGIN_DOC + ! the orbital gradient core/inactive -> active + ! we assume natural orbitals + END_DOC + implicit none + integer :: i,t + + integer :: ii,tt,v,vv,x,y + integer :: x3,y3 + + ii=list_core_inact(i) + tt=list_act(t) + gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii)) + gradvec_it-=occnum(tt)*Fipq(ii,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + x3=x+n_core_inact_orb + do y=1,n_act_orb + y3=y+n_core_inact_orb + gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3) + end do + end do + end do + gradvec_it*=2.D0 +end function gradvec_it + +real*8 function gradvec_ia(i,a) + BEGIN_DOC + ! the orbital gradient core/inactive -> virtual + END_DOC + implicit none + integer :: i,a,ii,aa + + ii=list_core_inact(i) + aa=list_virt(a) + gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) + gradvec_ia*=2.D0 + +end function gradvec_ia + +real*8 function gradvec_ta(t,a) + BEGIN_DOC + ! the orbital gradient active -> virtual + ! we assume natural orbitals + END_DOC + implicit none + integer :: t,a,tt,aa,v,vv,x,y + + tt=list_act(t) + aa=list_virt(a) + gradvec_ta=0.D0 + gradvec_ta+=occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa) + end do + end do + end do + gradvec_ta*=2.D0 + +end function gradvec_ta + diff --git a/src/casscf/h_apply.irp.f b/src/casscf/h_apply.irp.f new file mode 100644 index 00000000..6fcb2900 --- /dev/null +++ b/src/casscf/h_apply.irp.f @@ -0,0 +1,18 @@ +! Generates subroutine H_apply_cisd +! ---------------------------------- + +BEGIN_SHELL [ /usr/bin/env python2 ] +from generate_h_apply import H_apply +H = H_apply("cisd",do_double_exc=True) +print H + +from generate_h_apply import H_apply +H = H_apply("cisdtq",do_double_exc=True) +H.set_selection_pt2("epstein_nesbet_2x2") +print H + +H = H_apply("cisd_sym",do_double_exc=True) +H.filter_only_connected_to_hf() +print H +END_SHELL + diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f new file mode 100644 index 00000000..06aed6ef --- /dev/null +++ b/src/casscf/hessian.irp.f @@ -0,0 +1,687 @@ +use bitmasks + +BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] + BEGIN_DOC + ! calculate the orbital hessian 2 + ! + + by hand, + ! determinant per determinant, as for the gradient + ! + ! we assume that we have natural active orbitals + END_DOC + implicit none + integer :: indx,ihole,ipart + integer :: jndx,jhole,jpart + character*3 :: iexc,jexc + real*8 :: res + + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + endif + + do indx=1,nMonoEx + do jndx=1,nMonoEx + hessmat(indx,jndx)=0.D0 + end do + end do + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + iexc=excit_class(indx) + do jndx=indx,nMonoEx + jhole=excit(1,jndx) + jpart=excit(2,jndx) + jexc=excit_class(jndx) + call calc_hess_elem(ihole,ipart,jhole,jpart,res) + hessmat(indx,jndx)=res + hessmat(jndx,indx)=res + end do + end do + +END_PROVIDER + +subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res) + BEGIN_DOC + ! eq 19 of Siegbahn et al, Physica Scripta 1980 + ! we calculate 2 + ! + + + ! average over all states is performed. + ! no transition between states. + END_DOC + implicit none + integer :: ihole,ipart,ispin,mu,istate + integer :: jhole,jpart,jspin + integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:) + integer(bit_kind), allocatable :: det_nu(:,:) + integer(bit_kind), allocatable :: det_mu_pq(:,:) + integer(bit_kind), allocatable :: det_mu_rs(:,:) + integer(bit_kind), allocatable :: det_nu_rs(:,:) + integer(bit_kind), allocatable :: det_mu_pqrs(:,:) + integer(bit_kind), allocatable :: det_mu_rspq(:,:) + real*8 :: i_H_psi_array(N_states),phase,phase2,phase3 + real*8 :: i_H_j_element + allocate(det_mu(N_int,2)) + allocate(det_nu(N_int,2)) + allocate(det_mu_pq(N_int,2)) + allocate(det_mu_rs(N_int,2)) + allocate(det_nu_rs(N_int,2)) + allocate(det_mu_pqrs(N_int,2)) + allocate(det_mu_rspq(N_int,2)) + integer :: mu_pq_possible + integer :: mu_rs_possible + integer :: nu_rs_possible + integer :: mu_pqrs_possible + integer :: mu_rspq_possible + + res=0.D0 + + ! the terms <0|E E H |0> + do mu=1,n_det + ! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 + ! do the monoexcitation pq on it + call det_copy(det_mu,det_mu_pq,N_int) + call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq & + ,ihole,ipart,ispin,phase,mu_pq_possible) + if (mu_pq_possible.eq.1) then + ! possible, but not necessarily in the list + ! do the second excitation + do jspin=1,2 + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs& + ,jhole,jpart,jspin,phase2,mu_pqrs_possible) + ! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + end do + end if + ! try the de-excitation with opposite sign + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs& + ,jpart,jhole,jspin,phase2,mu_pqrs_possible) + phase2=-phase2 + ! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + end do + end if + end do + end if + ! exchange the notion of pq and rs + ! do the monoexcitation rs on the initial determinant + call det_copy(det_mu,det_mu_rs,N_int) + call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs & + ,jhole,jpart,ispin,phase2,mu_rs_possible) + if (mu_rs_possible.eq.1) then + ! do the second excitation + do jspin=1,2 + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq& + ,ihole,ipart,jspin,phase3,mu_rspq_possible) + ! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if + ! we may try the de-excitation, with opposite sign + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq& + ,ipart,ihole,jspin,phase3,mu_rspq_possible) + phase3=-phase3 + ! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if + end do + end if + ! + ! the operator E H E, we have to do a double loop over the determinants + ! we still have the determinant mu_pq and the phase in memory + if (mu_pq_possible.eq.1) then + do nu=1,N_det + call det_extract(det_nu,nu,N_int) + do jspin=1,2 + call det_copy(det_nu,det_nu_rs,N_int) + call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs & + ,jhole,jpart,jspin,phase2,nu_rs_possible) + ! excitation possible ? + if (nu_rs_possible.eq.1) then + call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element) + do istate=1,N_states + res+=2.D0*i_H_j_element*psi_coef(mu,istate) & + *psi_coef(nu,istate)*phase*phase2 + end do + end if + end do + end do + end if + end do + end do + + ! state-averaged Hessian + res*=1.D0/dble(N_states) + +end subroutine calc_hess_elem + +BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] + BEGIN_DOC + ! explicit hessian matrix from density matrices and integrals + ! of course, this will be used for a direct Davidson procedure later + ! we will not store the matrix in real life + ! formulas are broken down as functions for the 6 classes of matrix elements + ! + END_DOC + implicit none + integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart,indx_shift + + real*8 :: hessmat_itju + real*8 :: hessmat_itja + real*8 :: hessmat_itua + real*8 :: hessmat_iajb + real*8 :: hessmat_iatb + real*8 :: hessmat_taub + + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + endif + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(hessmat2,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) & + !$OMP PRIVATE(i,indx,jndx,j,ustart,t,u,a,bstart,indx_shift) + + !$OMP DO + do i=1,n_core_inact_orb + do t=1,n_act_orb + indx = t + (i-1)*n_act_orb + jndx=indx + do j=i,n_core_inact_orb + if (i.eq.j) then + ustart=t + else + ustart=1 + end if + do u=ustart,n_act_orb + hessmat2(jndx,indx)=hessmat_itju(i,t,j,u) + jndx+=1 + end do + end do + do j=1,n_core_inact_orb + do a=1,n_virt_orb + hessmat2(jndx,indx)=hessmat_itja(i,t,j,a) + jndx+=1 + end do + end do + do u=1,n_act_orb + do a=1,n_virt_orb + hessmat2(jndx,indx)=hessmat_itua(i,t,u,a) + jndx+=1 + end do + end do + end do + end do + !$OMP END DO NOWAIT + + indx_shift = n_core_inact_orb*n_act_orb + !$OMP DO + do a=1,n_virt_orb + do i=1,n_core_inact_orb + indx = a + (i-1)*n_virt_orb + indx_shift + jndx=indx + do j=i,n_core_inact_orb + if (i.eq.j) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(jndx,indx)=hessmat_iajb(i,a,j,b) + jndx+=1 + end do + end do + do t=1,n_act_orb + do b=1,n_virt_orb + hessmat2(jndx,indx)=hessmat_iatb(i,a,t,b) + jndx+=1 + end do + end do + end do + end do + !$OMP END DO NOWAIT + + indx_shift += n_core_inact_orb*n_virt_orb + !$OMP DO + do a=1,n_virt_orb + do t=1,n_act_orb + indx = a + (t-1)*n_virt_orb + indx_shift + jndx=indx + do u=t,n_act_orb + if (t.eq.u) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(jndx,indx)=hessmat_taub(t,a,u,b) + jndx+=1 + end do + end do + end do + end do + !$OMP END DO + + !$OMP END PARALLEL + + do jndx=1,nMonoEx + do indx=1,jndx-1 + hessmat2(indx,jndx) = hessmat2(jndx,indx) + enddo + enddo + + +END_PROVIDER + +real*8 function hessmat_itju(i,t,j,u) + BEGIN_DOC + ! 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 + ! + ! we assume natural orbitals + END_DOC + implicit none + integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj + real*8 :: term,t2 + + ii=list_core_inact(i) + tt=list_act(t) + if (i.eq.j) then + if (t.eq.u) then + ! diagonal element + term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) & + -2.D0*(Fipq(ii,ii)+Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq_no(tt,i,i,tt)-bielec_pqxx_no(tt,tt,i,i)) + term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq_no(tt,i,i,tt) & + -bielec_pqxx_no(tt,tt,i,i)) + term-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(vv,xx,i,i) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) + end do + end do + end do + else + ! it/iu, t != u + uu=list_act(u) + term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu)) + term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(tt,uu,i,j)) + term-=occnum(tt)*Fipq(uu,tt) + term-=(occnum(tt)+occnum(uu)) & + *(3.D0*bielec_PxxQ_no(tt,i,i,uu)-bielec_PQxx_no(uu,tt,i,i)) + do v=1,n_act_orb + vv=list_act(v) + ! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,i) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq_no(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(u,v,y,xx) + end do + end do + end do + end if + else + ! it/ju + jj=list_core_inact(j) + uu=list_act(u) + if (t.eq.u) then + term=occnum(tt)*Fipq(ii,jj) + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + else + term=0.D0 + end if + term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(tt,uu,i,j)) + term-=(occnum(tt)+occnum(uu))* & + (4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(uu,tt,i,j)) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,j) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq_no(vv,i,j,xx)) + end do + end do + end if + + term*=2.D0 + hessmat_itju=term + +end function hessmat_itju + +real*8 function hessmat_itja(i,t,j,a) + BEGIN_DOC + ! the orbital hessian for core/inactive -> active, core/inactive -> virtual + END_DOC + implicit none + integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y + real*8 :: term + + ! it/ja + ii=list_core_inact(i) + tt=list_act(t) + jj=list_core_inact(j) + aa=list_virt(a) + 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)) + term-=occnum(tt)*(4.D0*bielec_pxxq_no(aa,j,i,tt) & + -bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt)) + if (i.eq.j) then + term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt)) + term-=0.5D0*occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa) + end do + end do + end do + end if + term*=2.D0 + hessmat_itja=term + +end function hessmat_itja + +real*8 function hessmat_itua(i,t,u,a) + BEGIN_DOC + ! the orbital hessian for core/inactive -> active, active -> virtual + END_DOC + implicit none + integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 + real*8 :: term + + ii=list_core_inact(i) + tt=list_act(t) + t3=t+n_core_inact_orb + uu=list_act(u) + u3=u+n_core_inact_orb + aa=list_virt(a) + if (t.eq.u) then + term=-occnum(tt)*Fipq(aa,ii) + else + term=0.D0 + end if + term-=occnum(uu)*(bielec_pqxx_no(aa,ii,t3,u3)-4.D0*bielec_pqxx_no(aa,uu,t3,i)& + +bielec_pxxq_no(aa,t3,u3,ii)) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + do x=1,n_act_orb + integer :: x3 + xx=list_act(x) + x3=x+n_core_inact_orb + 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)) & + *bielec_pqxx_no(aa,xx,v3,i)) + end do + end do + if (t.eq.u) then + term+=Fipq(aa,ii)+Fapq(aa,ii) + end if + term*=2.D0 + hessmat_itua=term + +end function hessmat_itua + +real*8 function hessmat_iajb(i,a,j,b) + BEGIN_DOC + ! the orbital hessian for core/inactive -> virtual, core/inactive -> virtual + END_DOC + implicit none + integer :: i,a,j,b,ii,aa,jj,bb + real*8 :: term + + ii=list_core_inact(i) + aa=list_virt(a) + if (i.eq.j) then + if (a.eq.b) then + ! ia/ia + term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,aa)-bielec_pqxx_no(aa,aa,i,i)) + else + bb=list_virt(b) + ! ia/ib + term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb)) + term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,bb)-bielec_pqxx_no(aa,bb,i,i)) + end if + else + ! ia/jb + jj=list_core_inact(j) + bb=list_virt(b) + 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)) + if (a.eq.b) then + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + end if + end if + term*=2.D0 + hessmat_iajb=term + +end function hessmat_iajb + +real*8 function hessmat_iatb(i,a,t,b) + BEGIN_DOC + ! the orbital hessian for core/inactive -> virtual, active -> virtual + END_DOC + implicit none + integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 + real*8 :: term + + ii=list_core_inact(i) + aa=list_virt(a) + tt=list_act(t) + bb=list_virt(b) + 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)& + -bielec_pqxx_no(aa,bb,i,t3)) + if (a.eq.b) then + term-=Fipq(tt,ii)+Fapq(tt,ii) + term-=0.5D0*occnum(tt)*Fipq(tt,ii) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,ii) + end do + end do + end do + end if + term*=2.D0 + hessmat_iatb=term + +end function hessmat_iatb + +real*8 function hessmat_taub(t,a,u,b) + BEGIN_DOC + ! the orbital hessian for act->virt,act->virt + END_DOC + implicit none + integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y + integer :: v3,x3 + real*8 :: term,t1,t2,t3 + + double precision,allocatable :: P0tuvx_no_t(:,:,:) + double precision :: bielec_pqxx_no_2(n_act_orb,n_act_orb) + double precision :: bielec_pxxq_no_2(n_act_orb,n_act_orb) + tt=list_act(t) + aa=list_virt(a) + if (t == u) then + if (a == b) then + ! ta/ta + t1=occnum(tt)*Fipq(aa,aa) + t2=0.D0 + t3=0.D0 + t1-=occnum(tt)*Fipq(tt,tt) + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_inact_orb + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + t2+=P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) + end do + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_inact_orb + t2+=(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(aa,x3,v3,aa) + end do + end do + do y=1,n_act_orb + do x=1,n_act_orb + xx=list_act(x) + do v=1,n_act_orb + t3-=P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) + end do + end do + end do + term=t1+2.d0*(t2+t3) + else + bb=list_virt(b) + ! ta/tb b/=a + term=0.5d0*occnum(tt)*Fipq(aa,bb) + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_inact_orb + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + term = term + P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) + end do + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_inact_orb + term= term + (P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & + *bielec_pxxq_no(aa,x3,v3,bb) + end do + end do + term += term + end if + else + ! ta/ub t/=u + uu=list_act(u) + bb=list_virt(b) + allocate(P0tuvx_no_t(n_act_orb,n_act_orb,n_act_orb)) + P0tuvx_no_t(:,:,:) = P0tuvx_no(t,:,:,:) + do x=1,n_act_orb + x3=x+n_core_inact_orb + do v=1,n_act_orb + v3=v+n_core_inact_orb + bielec_pqxx_no_2(v,x) = bielec_pqxx_no(aa,bb,v3,x3) + bielec_pxxq_no_2(v,x) = bielec_pxxq_no(aa,v3,x3,bb) + end do + end do + term=0.D0 + do x=1,n_act_orb + do v=1,n_act_orb + term += P0tuvx_no_t(u,v,x)*bielec_pqxx_no_2(v,x) + term += bielec_pxxq_no_2(x,v) * (P0tuvx_no_t(x,v,u)+P0tuvx_no_t(x,u,v)) + end do + end do + term = 6.d0*term + if (a.eq.b) then + term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu)) + do v=1,n_act_orb + do y=1,n_act_orb + do x=1,n_act_orb + term-=P0tuvx_no_t(v,x,y)*bielecCI_no(x,y,v,uu) + term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt) + end do + end do + end do + end if + + end if + + term*=2.D0 + hessmat_taub=term + +end function hessmat_taub + +BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)] + BEGIN_DOC + ! the diagonal of the Hessian, needed for the Davidson procedure + END_DOC + implicit none + integer :: i,t,a,indx,indx_shift + real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(hessdiag,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) & + !$OMP PRIVATE(i,indx,t,a,indx_shift) + + !$OMP DO + do i=1,n_core_inact_orb + do t=1,n_act_orb + indx = t + (i-1)*n_act_orb + hessdiag(indx)=hessmat_itju(i,t,i,t) + end do + end do + !$OMP END DO NOWAIT + + indx_shift = n_core_inact_orb*n_act_orb + !$OMP DO + do a=1,n_virt_orb + do i=1,n_core_inact_orb + indx = a + (i-1)*n_virt_orb + indx_shift + hessdiag(indx)=hessmat_iajb(i,a,i,a) + end do + end do + !$OMP END DO NOWAIT + + indx_shift += n_core_inact_orb*n_virt_orb + !$OMP DO + do a=1,n_virt_orb + do t=1,n_act_orb + indx = a + (t-1)*n_virt_orb + indx_shift + hessdiag(indx)=hessmat_taub(t,a,t,a) + end do + end do + !$OMP END DO + !$OMP END PARALLEL + +END_PROVIDER diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f new file mode 100644 index 00000000..e4568405 --- /dev/null +++ b/src/casscf/mcscf_fock.irp.f @@ -0,0 +1,80 @@ +BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] + BEGIN_DOC + ! the inactive Fock matrix, in molecular orbitals + END_DOC + implicit none + integer :: p,q,k,kk,t,tt,u,uu + + do q=1,mo_num + do p=1,mo_num + Fipq(p,q)=one_ints_no(p,q) + end do + end do + + ! the inactive Fock matrix + do k=1,n_core_inact_orb + kk=list_core_inact(k) + do q=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) + end do + end do + end do + + if (bavard) then + integer :: i + write(6,*) + write(6,*) ' the diagonal of the inactive effective Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) + write(6,*) + end if + + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] + BEGIN_DOC + ! the active active Fock matrix, in molecular orbitals + ! we create them in MOs, quite expensive + ! + ! for an implementation in AOs we need first the natural orbitals + ! for forming an active density matrix in AOs + ! + END_DOC + implicit none + integer :: p,q,k,kk,t,tt,u,uu + + Fapq = 0.d0 + + ! the active Fock matrix, D0tu is diagonal + do t=1,n_act_orb + tt=list_act(t) + do q=1,mo_num + do p=1,mo_num + Fapq(p,q)+=occnum(tt) & + *(bielec_pqxx_no(p,q,tt,tt)-0.5D0*bielec_pxxq_no(p,tt,tt,q)) + end do + end do + end do + + if (bavard) then + integer :: i + write(6,*) + write(6,*) ' the effective Fock matrix over MOs' + write(6,*) + + write(6,*) + write(6,*) ' the diagonal of the inactive effective Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) + write(6,*) + write(6,*) + write(6,*) ' the diagonal of the active Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num) + write(6,*) + end if + + +END_PROVIDER + + diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f new file mode 100644 index 00000000..9ce90304 --- /dev/null +++ b/src/casscf/natorb.irp.f @@ -0,0 +1,231 @@ + BEGIN_PROVIDER [real*8, occnum, (mo_num)] + implicit none + BEGIN_DOC + ! MO occupation numbers + END_DOC + + integer :: i + occnum=0.D0 + do i=1,n_core_inact_orb + occnum(list_core_inact(i))=2.D0 + end do + + do i=1,n_act_orb + occnum(list_act(i))=occ_act(i) + end do + + if (bavard) then + write(6,*) ' occupation numbers ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do + endif + +END_PROVIDER + + + BEGIN_PROVIDER [ real*8, natorbsCI, (n_act_orb,n_act_orb) ] +&BEGIN_PROVIDER [ real*8, occ_act, (n_act_orb) ] + implicit none + BEGIN_DOC + ! Natural orbitals of CI + END_DOC + integer :: i, j + double precision :: Vt(n_act_orb,n_act_orb) + +! call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) + call svd(D0tu, size(D0tu,1), natorbsCI,size(natorbsCI,1), occ_act, Vt, size(Vt,1),n_act_orb,n_act_orb) + + if (bavard) then + write(6,*) ' found occupation numbers as ' + do i=1,n_act_orb + write(6,*) i,occ_act(i) + end do + + integer :: nmx + real*8 :: xmx + do i=1,n_act_orb + ! largest element of the eigenvector should be positive + xmx=0.D0 + nmx=0 + do j=1,n_act_orb + if (abs(natOrbsCI(j,i)).gt.xmx) then + nmx=j + xmx=abs(natOrbsCI(j,i)) + end if + end do + xmx=sign(1.D0,natOrbsCI(nmx,i)) + do j=1,n_act_orb + natOrbsCI(j,i)*=xmx + end do + + write(6,*) ' Eigenvector No ',i + write(6,'(5(I3,F12.5))') (j,natOrbsCI(j,i),j=1,n_act_orb) + end do + end if + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC + ! 4-index transformation of 2part matrices + END_DOC + integer :: i,j,k,l,p,q + real*8 :: d(n_act_orb) + + ! index per index + ! first quarter + P0tuvx_no(:,:,:,:) = P0tuvx(:,:,:,:) + + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + do q=1,n_act_orb + d(p)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(p,j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + do q=1,n_act_orb + d(p)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,p,k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + do q=1,n_act_orb + d(p)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,k,p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + do q=1,n_act_orb + d(p)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,k,l,p)=d(p) + end do + end do + end do + end do + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] + implicit none + BEGIN_DOC + ! Transformed one-e integrals + END_DOC + integer :: i,j, p, q + real*8 :: d(n_act_orb) + one_ints_no(:,:)=mo_one_e_integrals(:,:) + + ! 1st half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + do q=1,n_act_orb + d(p)+=one_ints_no(list_act(q),j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + one_ints_no(list_act(p),j)=d(p) + end do + end do + + ! 2nd half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + do q=1,n_act_orb + d(p)+=one_ints_no(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + one_ints_no(j,list_act(p))=d(p) + end do + end do +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, NatOrbsCI_mos, (mo_num, mo_num) ] + implicit none + BEGIN_DOC + ! Rotation matrix from current MOs to the CI natural MOs + END_DOC + integer :: p,q + + NatOrbsCI_mos(:,:) = 0.d0 + + do q = 1,mo_num + NatOrbsCI_mos(q,q) = 1.d0 + enddo + + do q = 1,n_act_orb + do p = 1,n_act_orb + NatOrbsCI_mos(list_act(p),list_act(q)) = natorbsCI(p,q) + enddo + enddo +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] + implicit none + BEGIN_DOC +! FCI natural orbitals + END_DOC + + call dgemm('N','N', ao_num,mo_num,mo_num,1.d0, & + mo_coef, size(mo_coef,1), & + NatOrbsCI_mos, size(NatOrbsCI_mos,1), 0.d0, & + NatOrbsFCI, size(NatOrbsFCI,1)) +END_PROVIDER + diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f new file mode 100644 index 00000000..0f9df016 --- /dev/null +++ b/src/casscf/neworbs.irp.f @@ -0,0 +1,181 @@ +BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] + implicit none + BEGIN_DOC + ! Single-excitation matrix + END_DOC + + integer :: i,j + + do i=1,nMonoEx+1 + do j=1,nMonoEx+1 + SXmatrix(i,j)=0.D0 + end do + end do + + do i=1,nMonoEx + SXmatrix(1,i+1)=gradvec2(i) + SXmatrix(1+i,1)=gradvec2(i) + end do + + do i=1,nMonoEx + do j=1,nMonoEx + SXmatrix(i+1,j+1)=hessmat2(i,j) + SXmatrix(j+1,i+1)=hessmat2(i,j) + end do + end do + + if (bavard) then + do i=2,nMonoEx + write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) + end do + end if + + +END_PROVIDER + + BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)] +&BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)] + implicit none + BEGIN_DOC + ! Eigenvectors/eigenvalues of the single-excitation matrix + END_DOC + call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) +END_PROVIDER + + BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)] +&BEGIN_PROVIDER [real*8, energy_improvement] + implicit none + BEGIN_DOC + ! Best eigenvector of the single-excitation matrix + END_DOC + integer :: ierr,matz,i + real*8 :: c0 + + if (bavard) then + write(6,*) ' SXdiag : lowest 5 eigenvalues ' + write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1) + write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) + write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) + write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) + write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) + write(6,*) + write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) + endif + energy_improvement = SXeigenval(1) + + integer :: best_vector + real*8 :: best_overlap + best_overlap=0.D0 + best_vector = -1000 + do i=1,nMonoEx+1 + if (SXeigenval(i).lt.0.D0) then + if (abs(SXeigenvec(1,i)).gt.best_overlap) then + best_overlap=abs(SXeigenvec(1,i)) + best_vector=i + end if + end if + end do + if(best_vector.lt.0)then + best_vector = minloc(SXeigenval,nMonoEx+1) + endif + energy_improvement = SXeigenval(best_vector) + + c0=SXeigenvec(1,best_vector) + + if (bavard) then + write(6,*) ' SXdiag : eigenvalue for best overlap with ' + write(6,*) ' previous orbitals = ',SXeigenval(best_vector) + write(6,*) ' weight of the 1st element ',c0 + endif + + do i=1,nMonoEx+1 + SXvector(i)=SXeigenvec(i,best_vector)/c0 + end do + + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ] + implicit none + BEGIN_DOC + ! Updated orbitals + END_DOC + integer :: i,j,ialph + + call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, & + NatOrbsFCI, size(NatOrbsFCI,1), & + Umat, size(Umat,1), 0.d0, & + NewOrbs, size(NewOrbs,1)) + +END_PROVIDER + +BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] + implicit none + BEGIN_DOC + ! Orbital rotation matrix + END_DOC + integer :: i,j,indx,k,iter,t,a,ii,tt,aa + logical :: converged + + real*8 :: Tpotmat (mo_num,mo_num), Tpotmat2 (mo_num,mo_num) + real*8 :: Tmat(mo_num,mo_num) + real*8 :: f + + ! the orbital rotation matrix T + Tmat(:,:)=0.D0 + indx=1 + do i=1,n_core_inact_orb + ii=list_core_inact(i) + do t=1,n_act_orb + tt=list_act(t) + indx+=1 + Tmat(ii,tt)= SXvector(indx) + Tmat(tt,ii)=-SXvector(indx) + end do + end do + do i=1,n_core_inact_orb + ii=list_core_inact(i) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(ii,aa)= SXvector(indx) + Tmat(aa,ii)=-SXvector(indx) + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(tt,aa)= SXvector(indx) + Tmat(aa,tt)=-SXvector(indx) + end do + end do + + ! Form the exponential + + Tpotmat(:,:)=0.D0 + Umat(:,:) =0.D0 + do i=1,mo_num + Tpotmat(i,i)=1.D0 + Umat(i,i) =1.d0 + end do + iter=0 + converged=.false. + do while (.not.converged) + iter+=1 + f = 1.d0 / dble(iter) + Tpotmat2(:,:) = Tpotmat(:,:) * f + call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, & + Tpotmat2, size(Tpotmat2,1), & + Tmat, size(Tmat,1), 0.d0, & + Tpotmat, size(Tpotmat,1)) + Umat(:,:) = Umat(:,:) + Tpotmat(:,:) + + converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30) + end do +END_PROVIDER + + + diff --git a/src/casscf/save_energy.irp.f b/src/casscf/save_energy.irp.f new file mode 100644 index 00000000..8729c5af --- /dev/null +++ b/src/casscf/save_energy.irp.f @@ -0,0 +1,9 @@ +subroutine save_energy(E,pt2) + implicit none + BEGIN_DOC +! Saves the energy in |EZFIO|. + END_DOC + double precision, intent(in) :: E(N_states), pt2(N_states) + call ezfio_set_casscf_energy(E(1:N_states)) + call ezfio_set_casscf_energy_pt2(E(1:N_states)+pt2(1:N_states)) +end diff --git a/src/casscf/test_pert_2rdm.irp.f b/src/casscf/test_pert_2rdm.irp.f new file mode 100644 index 00000000..7c40de0f --- /dev/null +++ b/src/casscf/test_pert_2rdm.irp.f @@ -0,0 +1,29 @@ +program test_pert_2rdm + implicit none + read_wf = .True. + touch read_wf +!call get_pert_2rdm + integer :: i,j,k,l,ii,jj,kk,ll + double precision :: accu , get_two_e_integral, integral + accu = 0.d0 + print*,'n_orb_pert_rdm = ',n_orb_pert_rdm + do ii = 1, n_orb_pert_rdm + i = list_orb_pert_rdm(ii) + do jj = 1, n_orb_pert_rdm + j = list_orb_pert_rdm(jj) + do kk = 1, n_orb_pert_rdm + k= list_orb_pert_rdm(kk) + do ll = 1, n_orb_pert_rdm + l = list_orb_pert_rdm(ll) + integral = get_two_e_integral(i,j,k,l,mo_integrals_map) +! if(dabs(pert_2rdm_provider(ii,jj,kk,ll) * integral).gt.1.d-12)then +! print*,i,j,k,l +! print*,pert_2rdm_provider(ii,jj,kk,ll) * integral,pert_2rdm_provider(ii,jj,kk,ll), pert_2rdm_provider(ii,jj,kk,ll), integral +! endif + accu += pert_2rdm_provider(ii,jj,kk,ll) * integral + enddo + enddo + enddo + enddo + print*,'accu = ',accu +end diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f new file mode 100644 index 00000000..1d70e087 --- /dev/null +++ b/src/casscf/tot_en.irp.f @@ -0,0 +1,101 @@ + BEGIN_PROVIDER [real*8, etwo] +&BEGIN_PROVIDER [real*8, eone] +&BEGIN_PROVIDER [real*8, eone_bis] +&BEGIN_PROVIDER [real*8, etwo_bis] +&BEGIN_PROVIDER [real*8, etwo_ter] +&BEGIN_PROVIDER [real*8, ecore] +&BEGIN_PROVIDER [real*8, ecore_bis] + implicit none + integer :: t,u,v,x,i,ii,tt,uu,vv,xx,j,jj,t3,u3,v3,x3 + real*8 :: e_one_all,e_two_all + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_inact_orb + ii=list_core_inact(i) + e_one_all+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_inact_orb + jj=list_core_inact(j) + e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_inact_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_inact_orb + e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & + -bielec_PQxx(tt,ii,i,u3)) + end do + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do u=1,n_act_orb + uu=list_act(u) + e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu) + do v=1,n_act_orb + v3=v+n_core_inact_orb + do x=1,n_act_orb + x3=x+n_core_inact_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3) + end do + end do + end do + end do + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_inact_orb + ii=list_core_inact(i) + ecore +=2.D0*mo_one_e_integrals(ii,ii) + ecore_bis+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_inact_orb + jj=list_core_inact(j) + 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) + end do + end do + eone =0.D0 + eone_bis=0.D0 + etwo =0.D0 + etwo_bis=0.D0 + etwo_ter=0.D0 + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_inact_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_inact_orb + eone +=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_inact_orb + ii=list_core_inact(i) + eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & + -bielec_PQxx(tt,ii,i,u3)) + eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) & + -bielec_PxxQ(tt,i,i,uu)) + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_inact_orb + real*8 :: h1,h2,h3 + h1=bielec_PQxx(tt,uu,v3,x3) + h2=bielec_PxxQ(tt,u3,v3,xx) + h3=bielecCI(t,u,v,xx) + etwo +=P0tuvx(t,u,v,x)*h1 + etwo_bis+=P0tuvx(t,u,v,x)*h2 + etwo_ter+=P0tuvx(t,u,v,x)*h3 + if ((h1.ne.h2).or.(h1.ne.h3)) then + write(6,9901) t,u,v,x,h1,h2,h3 + 9901 format('aie: ',4I4,3E20.12) + end if + end do + end do + end do + end do + +END_PROVIDER + + diff --git a/src/cipsi/NEED b/src/cipsi/NEED index 0cab61d0..c9dc92c0 100644 --- a/src/cipsi/NEED +++ b/src/cipsi/NEED @@ -3,3 +3,4 @@ zmq mpi davidson_undressed iterations +two_body_rdm diff --git a/src/cipsi/cipsi.irp.f b/src/cipsi/cipsi.irp.f index 7e292d6e..ba922c49 100644 --- a/src/cipsi/cipsi.irp.f +++ b/src/cipsi/cipsi.irp.f @@ -13,6 +13,7 @@ subroutine run_cipsi rss = memory_of_double(N_states)*4.d0 call check_mem(rss,irp_here) + N_iter = 1 allocate (pt2(N_states), zeros(N_states), rpt2(N_states), norm(N_states), variance(N_states)) double precision :: hf_energy_ref diff --git a/src/cipsi/lock_2rdm.irp.f b/src/cipsi/lock_2rdm.irp.f new file mode 100644 index 00000000..e69de29b diff --git a/src/cipsi/pert_rdm_providers.irp.f b/src/cipsi/pert_rdm_providers.irp.f new file mode 100644 index 00000000..85bea747 --- /dev/null +++ b/src/cipsi/pert_rdm_providers.irp.f @@ -0,0 +1,183 @@ + +use bitmasks +use omp_lib + +BEGIN_PROVIDER [ integer(omp_lock_kind), pert_2rdm_lock] + use f77_zmq + implicit none + call omp_init_lock(pert_2rdm_lock) +END_PROVIDER + +BEGIN_PROVIDER [logical , pert_2rdm ] + implicit none + pert_2rdm = .False. +END_PROVIDER + +BEGIN_PROVIDER [integer, n_orb_pert_rdm] + implicit none + n_orb_pert_rdm = n_act_orb +END_PROVIDER + +BEGIN_PROVIDER [integer, list_orb_reverse_pert_rdm, (mo_num)] + implicit none + list_orb_reverse_pert_rdm = list_act_reverse + +END_PROVIDER + +BEGIN_PROVIDER [integer, list_orb_pert_rdm, (n_orb_pert_rdm)] + implicit none + list_orb_pert_rdm = list_act + +END_PROVIDER + +BEGIN_PROVIDER [double precision, pert_2rdm_provider, (n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm)] + implicit none + pert_2rdm_provider = 0.d0 + +END_PROVIDER + +subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection_reverse, n_det_connection) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: n_det_connection + double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection) + integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_num, mo_num) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num) + double precision, intent(in) :: fock_diag_tmp(mo_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + double precision, intent(inout) :: variance(N_states) + double precision, intent(inout) :: norm(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, sum_e_pert, tmp, alpha_h_psi, coef(N_states) + double precision, external :: diag_H_mat_elem_fock + double precision :: E_shift + + logical, external :: detEq + double precision, allocatable :: values(:) + integer, allocatable :: keys(:,:) + integer :: nkeys + integer :: sze_buff + sze_buff = 5 * mo_num ** 2 + allocate(keys(4,sze_buff),values(sze_buff)) + nkeys = 0 + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + E_shift = 0.d0 + + if (h0_type == 'SOP') then + j = det_to_occ_pattern(i_generator) + E_shift = psi_det_Hii(i_generator) - psi_occ_pattern_Hii(j) + endif + + do p1=1,mo_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + + do p2=ib,mo_num + +! ----- +! /!\ Generating only single excited determinants doesn't work because a +! determinant generated by a single excitation may be doubly excited wrt +! to a determinant of the future. In that case, the determinant will be +! detected as already generated when generating in the future with a +! double excitation. +! +! if (.not.do_singles) then +! if ((h1 == p1) .or. (h2 == p2)) then +! cycle +! endif +! endif +! +! if (.not.do_doubles) then +! if ((h1 /= p1).and.(h2 /= p2)) then +! cycle +! endif +! endif +! ----- + + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + + + if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + if (do_only_cas) then + integer, external :: number_of_holes, number_of_particles + if (number_of_particles(det)>0) then + cycle + endif + if (number_of_holes(det)>0) then + cycle + endif + endif + + if (do_ddci) then + logical, external :: is_a_two_holes_two_particles + if (is_a_two_holes_two_particles(det)) then + cycle + endif + endif + + if (do_only_1h1p) then + logical, external :: is_a_1h1p + if (.not.is_a_1h1p(det)) cycle + endif + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + + sum_e_pert = 0d0 + integer :: degree + call get_excitation_degree(det,HF_bitmask,degree,N_int) + if(degree == 2)cycle + do istate=1,N_states + delta_E = E0(istate) - Hii + E_shift + alpha_h_psi = mat(istate, p1, p2) + val = alpha_h_psi + alpha_h_psi + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * (tmp - delta_E) + coef(istate) = e_pert / alpha_h_psi + print*,e_pert,coef,alpha_h_psi + pt2(istate) = pt2(istate) + e_pert + variance(istate) = variance(istate) + alpha_h_psi * alpha_h_psi + norm(istate) = norm(istate) + coef(istate) * coef(istate) + + if (weight_selection /= 5) then + ! Energy selection + sum_e_pert = sum_e_pert + e_pert * selection_weight(istate) + + else + ! Variance selection + sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate) + endif + end do + call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff) + + if(sum_e_pert <= buf%mini) then + call add_to_selection_buffer(buf, det, sum_e_pert) + end if + end do + end do + call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) +end + + diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index 9f891320..7825d24c 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -135,7 +135,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in) PROVIDE psi_occ_pattern_hii det_to_occ_pattern endif - if (N_det < max(4,N_states)) then + if (N_det <= max(4,N_states)) then pt2=0.d0 variance=0.d0 norm=0.d0 @@ -719,6 +719,15 @@ END_PROVIDER double precision :: rss double precision, external :: memory_of_double, memory_of_int + if (N_det_generators == 1) then + pt2_w = 1.d0 + pt2_cw = 1.d0 + pt2_W_T = 1.d0 + pt2_u_0 = 1.d0 + pt2_n_0 = 1 + return + endif + rss = memory_of_double(2*N_det_generators+1) call check_mem(rss,irp_here) @@ -754,7 +763,7 @@ END_PROVIDER end if pt2_n_0(1) += 1 if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then - stop "teeth building failed" + print *, "teeth building failed" end if end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f index 70ad543f..d9730d7f 100644 --- a/src/cipsi/run_selection_slave.irp.f +++ b/src/cipsi/run_selection_slave.irp.f @@ -61,7 +61,6 @@ subroutine run_selection_slave(thread,iproc,energy) ! Only first time bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2) call create_selection_buffer(bsize, bsize*2, buf) -! call create_selection_buffer(N, N*2, buf2) buffer_ready = .True. else ASSERT (N == buf%N) diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index df31bc39..248876ef 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -1,3 +1,4 @@ + use bitmasks BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ] @@ -248,6 +249,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d integer,allocatable :: tmp_array(:) integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) logical, allocatable :: banned(:,:,:), bannedOrb(:,:) + double precision, allocatable :: coef_fullminilist_rev(:,:) double precision, allocatable :: mat(:,:,:) @@ -546,6 +548,14 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d allocate (fullminilist (N_int, 2, fullinteresting(0)), & minilist (N_int, 2, interesting(0)) ) + if(pert_2rdm)then + allocate(coef_fullminilist_rev(N_states,fullinteresting(0))) + do i=1,fullinteresting(0) + do j = 1, N_states + coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j) + enddo + enddo + endif do i=1,fullinteresting(0) fullminilist(1:N_int,1:2,i) = psi_det_sorted(1:N_int,1:2,fullinteresting(i)) enddo @@ -597,12 +607,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf) + if(.not.pert_2rdm)then + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf) + else + call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0)) + endif end if enddo if(s1 /= s2) monoBdo = .false. enddo deallocate(fullminilist,minilist) + if(pert_2rdm)then + deallocate(coef_fullminilist_rev) + endif enddo enddo deallocate(preinteresting, prefullinteresting, interesting, fullinteresting) @@ -633,6 +650,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d double precision :: E_shift logical, external :: detEq + double precision, allocatable :: values(:) + integer, allocatable :: keys(:,:) + integer :: nkeys + if(sp == 3) then s1 = 1 @@ -683,6 +704,16 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + if (do_only_cas) then + integer, external :: number_of_holes, number_of_particles + if (number_of_particles(det)>0) then + cycle + endif + if (number_of_holes(det)>0) then + cycle + endif + endif + if (do_ddci) then logical, external :: is_a_two_holes_two_particles if (is_a_two_holes_two_particles(det)) then @@ -735,7 +766,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d end do end - subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) use bitmasks implicit none diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index ae2b7519..4f968ef7 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -12,6 +12,7 @@ subroutine run_stochastic_cipsi double precision, external :: memory_of_double PROVIDE H_apply_buffer_allocated N_generators_bitmask + N_iter = 1 threshold_generators = 1.d0 SOFT_TOUCH threshold_generators diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f new file mode 100644 index 00000000..260c48fd --- /dev/null +++ b/src/cipsi/update_2rdm.irp.f @@ -0,0 +1,223 @@ +use bitmasks + +subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: n_det_connection,sze_buff + double precision, intent(in) :: coef(N_states) + integer(bit_kind), intent(in) :: det(N_int,2) + integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) + double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection) + integer, intent(inout) :: keys(4,sze_buff),nkeys + double precision, intent(inout) :: values(sze_buff) + integer :: i,j + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase, contrib + do i = 1, n_det_connection + call get_excitation(det,psi_det_connection(1,1,i),exc,degree,phase,N_int) + if(degree.gt.2)cycle + contrib = 0.d0 + do j = 1, N_states + contrib += state_average_weight(j) * psi_coef_connection_reverse(j,i) * phase * coef(j) + enddo + ! case of single excitations + if(degree == 1)then + if (nkeys + 6 * elec_alpha_num .ge. sze_buff)then + call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) + nkeys = 0 + endif + call update_buffer_single_exc_rdm(det,psi_det_connection(1,1,i),exc,phase,contrib,nkeys,keys,values,sze_buff) + else + !! case of double excitations + ! if (nkeys + 4 .ge. sze_buff)then + ! call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) + ! nkeys = 0 + ! endif + ! call update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) + endif + enddo +!call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) +!nkeys = 0 + +end + +subroutine update_buffer_single_exc_rdm(det1,det2,exc,phase,contrib,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: sze_buff + integer(bit_kind), intent(in) :: det1(N_int,2) + integer(bit_kind), intent(in) :: det2(N_int,2) + integer,intent(in) :: exc(0:2,2,2) + double precision,intent(in) :: phase, contrib + integer, intent(inout) :: nkeys, keys(4,sze_buff) + double precision, intent(inout):: values(sze_buff) + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2),ispin,other_spin + integer :: h1,h2,p1,p2,i + call bitstring_to_list_ab(det1, occ, n_occ_ab, N_int) + + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + ispin = 1 + other_spin = 2 + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + ispin = 2 + other_spin = 1 + endif + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + !update the alpha/beta part + do i = 1, n_occ_ab(other_spin) + h2 = occ(i,other_spin) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + !update the same spin part +!do i = 1, n_occ_ab(ispin) +! h2 = occ(i,ispin) +! if(list_orb_reverse_pert_rdm(h2).lt.0)return +! h2 = list_orb_reverse_pert_rdm(h2) + +! nkeys += 1 +! values(nkeys) = 0.5d0 * contrib * phase +! keys(1,nkeys) = h1 +! keys(2,nkeys) = h2 +! keys(3,nkeys) = p1 +! keys(4,nkeys) = h2 + +! nkeys += 1 +! values(nkeys) = - 0.5d0 * contrib * phase +! keys(1,nkeys) = h1 +! keys(2,nkeys) = h2 +! keys(3,nkeys) = h2 +! keys(4,nkeys) = p1 +! +! nkeys += 1 +! values(nkeys) = 0.5d0 * contrib * phase +! keys(1,nkeys) = h2 +! keys(2,nkeys) = h1 +! keys(3,nkeys) = h2 +! keys(4,nkeys) = p1 + +! nkeys += 1 +! values(nkeys) = - 0.5d0 * contrib * phase +! keys(1,nkeys) = h2 +! keys(2,nkeys) = h1 +! keys(3,nkeys) = p1 +! keys(4,nkeys) = h2 +!enddo + +end + +subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: sze_buff + integer,intent(in) :: exc(0:2,2,2) + double precision,intent(in) :: phase, contrib + integer, intent(inout) :: nkeys, keys(4,sze_buff) + double precision, intent(inout):: values(sze_buff) + integer :: h1,h2,p1,p2 + + if (exc(0,1,1) == 1) then + ! Double alpha/beta + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + ! check if the orbitals involved are within the orbital range + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + if(list_orb_reverse_pert_rdm(p2).lt.0)return + p2 = list_orb_reverse_pert_rdm(p2) + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = p1 + keys(2,nkeys) = p2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + + else + if (exc(0,1,1) == 2) then + ! Double alpha/alpha + h1 = exc(1,1,1) + h2 = exc(2,1,1) + p1 = exc(1,2,1) + p2 = exc(2,2,1) + else if (exc(0,1,2) == 2) then + ! Double beta + h1 = exc(1,1,2) + h2 = exc(2,1,2) + p1 = exc(1,2,2) + p2 = exc(2,2,2) + endif + ! check if the orbitals involved are within the orbital range + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + if(list_orb_reverse_pert_rdm(p2).lt.0)return + p2 = list_orb_reverse_pert_rdm(p2) + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + +end + + diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index 65f943d3..aaa29f59 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -46,34 +46,6 @@ program cisd END_DOC read_wf = .False. SOFT_TOUCH read_wf - call run -end - -subroutine run - implicit none - integer :: i - - if(pseudo_sym)then - call H_apply_cisd_sym - else - call H_apply_cisd - endif - print *, 'N_det = ', N_det - print*,'******************************' - print *, 'Energies of the states:' - do i = 1,N_states - print *, i, CI_energy(i) - enddo - if (N_states > 1) then - print*,'******************************' - print*,'Excitation energies ' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1) - enddo - endif - psi_coef = ci_eigenvectors - SOFT_TOUCH psi_coef - call save_wavefunction - call ezfio_set_cisd_energy(CI_energy) - + call only_act_bitmask + call run_cisd end diff --git a/src/cisd/cisd_routine.irp.f b/src/cisd/cisd_routine.irp.f new file mode 100644 index 00000000..f9e477b1 --- /dev/null +++ b/src/cisd/cisd_routine.irp.f @@ -0,0 +1,42 @@ +subroutine only_act_bitmask + implicit none + integer :: i,j,k + do k = 1, N_generators_bitmask + do j = 1, 6 + do i = 1, N_int + generators_bitmask(i,1,j,k) = act_bitmask(i,1) + generators_bitmask(i,2,j,k) = act_bitmask(i,2) + enddo + enddo + enddo + touch generators_bitmask +end + +subroutine run_cisd + implicit none + integer :: i + + if(pseudo_sym)then + call H_apply_cisd_sym + else + call H_apply_cisd + endif + print *, 'N_det = ', N_det + print*,'******************************' + print *, 'Energies of the states:' + do i = 1,N_states + print *, i, CI_energy(i) + enddo + if (N_states > 1) then + print*,'******************************' + print*,'Excitation energies ' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1) + enddo + endif + psi_coef = ci_eigenvectors + SOFT_TOUCH psi_coef + call save_wavefunction + call ezfio_set_cisd_energy(CI_energy) + +end diff --git a/src/davidson/u0_wee_u0.irp.f b/src/davidson/u0_wee_u0.irp.f index c1f163d4..0c543aca 100644 --- a/src/davidson/u0_wee_u0.irp.f +++ b/src/davidson/u0_wee_u0.irp.f @@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, psi_energy_two_e, (N_states) ] 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) do i=N_det+1,N_states - psi_energy(i) = 0.d0 + psi_energy_two_e(i) = 0.d0 enddo END_PROVIDER diff --git a/src/density_for_dft/density_for_dft.irp.f b/src/density_for_dft/density_for_dft.irp.f index 4514f111..c925bdf8 100644 --- a/src/density_for_dft/density_for_dft.irp.f +++ b/src/density_for_dft/density_for_dft.irp.f @@ -106,12 +106,31 @@ END_PROVIDER BEGIN_PROVIDER [double precision, one_e_dm_average_mo_for_dft, (mo_num,mo_num)] implicit none integer :: i - one_e_dm_average_mo_for_dft = 0.d0 + one_e_dm_average_mo_for_dft = one_e_dm_average_alpha_mo_for_dft + one_e_dm_average_beta_mo_for_dft +END_PROVIDER + + +BEGIN_PROVIDER [double precision, one_e_dm_average_alpha_mo_for_dft, (mo_num,mo_num)] + implicit none + integer :: i + one_e_dm_average_alpha_mo_for_dft = 0.d0 do i = 1, N_states - one_e_dm_average_mo_for_dft(:,:) += one_e_dm_mo_for_dft(:,:,i) * state_average_weight(i) + one_e_dm_average_alpha_mo_for_dft(:,:) += one_e_dm_mo_alpha_for_dft(:,:,i) * state_average_weight(i) enddo END_PROVIDER + +BEGIN_PROVIDER [double precision, one_e_dm_average_beta_mo_for_dft, (mo_num,mo_num)] + implicit none + integer :: i + one_e_dm_average_beta_mo_for_dft = 0.d0 + do i = 1, N_states + one_e_dm_average_beta_mo_for_dft(:,:) += one_e_dm_mo_beta_for_dft(:,:,i) * state_average_weight(i) + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_e_dm_alpha_ao_for_dft, (ao_num,ao_num,N_states) ] &BEGIN_PROVIDER [ double precision, one_e_dm_beta_ao_for_dft, (ao_num,ao_num,N_states) ] BEGIN_DOC diff --git a/src/determinants/two_e_density_matrix.irp.pouet b/src/determinants/two_e_density_matrix.irp.pouet new file mode 100644 index 00000000..7f8f4896 --- /dev/null +++ b/src/determinants/two_e_density_matrix.irp.pouet @@ -0,0 +1,609 @@ + + BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_bod_alpha_beta(i,j,k,l) = + ! 1 1 2 2 = chemist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: dim1,dim2,dim3,dim4 + double precision :: cpu_0,cpu_1 + dim1 = mo_num + dim2 = mo_num + dim3 = mo_num + dim4 = mo_num + two_bod_alpha_beta_mo = 0.d0 + print*,'providing two_bod_alpha_beta ...' + call wall_time(cpu_0) + call two_body_dm_nstates_openmp(two_bod_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(cpu_1) + print*,'two_bod_alpha_beta provided in',dabs(cpu_1-cpu_0) + + integer :: ii,jj,i,j,k,l + if(no_core_density .EQ. "no_core_dm")then + print*,'USING THE VALENCE ONLY TWO BODY DENSITY' + + do ii = 1, n_core_orb ! 1 + i = list_core(ii) + do j = 1, mo_num ! 2 + do k = 1, mo_num ! 1 + do l = 1, mo_num ! 2 + ! 2 2 1 1 + two_bod_alpha_beta_mo(l,j,k,i,:) = 0.d0 + two_bod_alpha_beta_mo(j,l,k,i,:) = 0.d0 + two_bod_alpha_beta_mo(l,j,i,k,:) = 0.d0 + two_bod_alpha_beta_mo(j,l,i,k,:) = 0.d0 + + two_bod_alpha_beta_mo(k,i,l,j,:) = 0.d0 + two_bod_alpha_beta_mo(k,i,j,l,:) = 0.d0 + two_bod_alpha_beta_mo(i,k,l,j,:) = 0.d0 + two_bod_alpha_beta_mo(i,k,j,l,:) = 0.d0 + enddo + enddo + enddo + enddo + + + endif + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_bod_alpha_beta_mo_physicist,(i,j,k,l) = + ! 1 2 1 2 = physicist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: i,j,k,l,istate + double precision :: cpu_0,cpu_1 + two_bod_alpha_beta_mo_physicist = 0.d0 + print*,'providing two_bod_alpha_beta_mo_physicist ...' + call wall_time(cpu_0) + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + ! 1 2 1 2 1 1 2 2 + two_bod_alpha_beta_mo_physicist(l,k,i,j,istate) = two_bod_alpha_beta_mo(i,l,j,k,istate) + enddo + enddo + enddo + enddo + enddo + call wall_time(cpu_1) + print*,'two_bod_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + + END_PROVIDER + + + subroutine two_body_dm_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! 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,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,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 two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,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 two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call two_body_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call two_body_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call two_body_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call two_body_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call two_body_dm_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select + end + BEGIN_TEMPLATE + + subroutine two_body_dm_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + double precision :: hij, sij + 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, nmax + integer*8 :: k8 + + 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 + + ! Alpha/Beta double excitations + ! ============================= + + 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) + + 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 + ! ----------------------- + + 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) + !!!!!!!!!!!!!!!!!! ALPHA BETA + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_body_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + + + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! 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) + + 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) + !!!! MONO SPIN + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + + enddo + + + !! Compute Hij for all alpha doubles + !! ---------------------------------- + ! + !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) + + ! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + + ! 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) + + ! 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) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + enddo + ! + !! Compute Hij for all beta doubles + !! ---------------------------------- + ! + !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) + + ! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + ! l_a = psi_bilinear_matrix_transp_order(l_b) + ! ASSERT (l_a <= N_det) + + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + ! 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_H_mat_elem_erf, diag_S_mat_elem + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_two_body_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4) + + end do + deallocate(buffer, singles_a, singles_b, doubles, idx) + + end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + + subroutine diagonal_contrib_to_two_body_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + enddo + end + + subroutine diagonal_contrib_to_all_two_body_dm(det_1,c_1,big_array_ab,big_array_aa,big_array_bb,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_ab(h1,h1,h2,h2,istate) += c_1_bis + enddo + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array_aa(h1,h2,h1,h2,istate) -= c_1_bis + big_array_aa(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_bb(h1,h1,h2,h2,istate) += c_1_bis + big_array_bb(h1,h2,h1,h2,istate) -= c_1_bis + enddo + enddo + enddo + end + + + subroutine off_diagonal_double_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate) +! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_single_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + 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 + 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 (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end diff --git a/src/dft_one_e/e_xc_general.irp.f b/src/dft_one_e/e_xc_general.irp.f index dc8b9d9a..fc9f9fd2 100644 --- a/src/dft_one_e/e_xc_general.irp.f +++ b/src/dft_one_e/e_xc_general.irp.f @@ -15,7 +15,7 @@ prefix = "" for f in functionals: print """ %sif (trim(exchange_functional) == '%s') then - energy_x = energy_x_%s"""%(prefix, f, f) + energy_x = (1.d0 - HF_exchange ) * energy_x_%s"""%(prefix, f, f) prefix = "else " print """ else diff --git a/src/dft_one_e/pot_general.irp.f b/src/dft_one_e/pot_general.irp.f index 237af8c0..2f45a464 100644 --- a/src/dft_one_e/pot_general.irp.f +++ b/src/dft_one_e/pot_general.irp.f @@ -17,8 +17,8 @@ prefix = "" for f in functionals: print """ %sif (trim(exchange_functional) == '%s') then - potential_x_alpha_ao = potential_x_alpha_ao_%s - potential_x_beta_ao = potential_x_beta_ao_%s"""%(prefix, f, f, f) + potential_x_alpha_ao = ( 1.d0 - HF_exchange ) * potential_x_alpha_ao_%s + potential_x_beta_ao = ( 1.d0 - HF_exchange ) * potential_x_beta_ao_%s"""%(prefix, f, f, f) prefix = "else " print """ else diff --git a/src/dft_utils_in_r/mo_in_r.irp.f b/src/dft_utils_in_r/mo_in_r.irp.f index 60cd59f2..bfcc8abb 100644 --- a/src/dft_utils_in_r/mo_in_r.irp.f +++ b/src/dft_utils_in_r/mo_in_r.irp.f @@ -32,6 +32,7 @@ ! k = 1 : x, k= 2, y, k 3, z END_DOC integer :: m + print*,'mo_num,n_points_final_grid',mo_num,n_points_final_grid mos_grad_in_r_array = 0.d0 do m=1,3 call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_grad_in_r_array(1,1,m),mo_num) diff --git a/src/dft_utils_one_e/ec_lyp_2.irp.f b/src/dft_utils_one_e/ec_lyp_2.irp.f new file mode 100644 index 00000000..e97a0e00 --- /dev/null +++ b/src/dft_utils_one_e/ec_lyp_2.irp.f @@ -0,0 +1,28 @@ +double precision function ec_lyp2(RhoA,RhoB,GA,GB,GAB) + include 'constants.include.F' + implicit none + double precision, intent(in) :: RhoA,RhoB,GA,GB,GAB + double precision :: Tol,caa,cab,cac,cad,cae,RA,RB,comega,cdelta,cLaa,cLbb,cLab,E + ec_lyp2 = 0.d0 + Tol=1D-14 + E=2.718281828459045D0 + caa=0.04918D0 + cab=0.132D0 + cac=0.2533D0 + cad=0.349D0 + cae=(2D0**(11D0/3D0))*((3D0/10D0)*((3D0*(Pi**2D0))**(2D0/3D0))) + + + RA = MAX(RhoA,0D0) + RB = MAX(RhoB,0D0) + IF ((RA.gt.Tol).OR.(RB.gt.Tol)) THEN + IF ((RA.gt.Tol).AND.(RB.gt.Tol)) THEN + comega = 1D0/(E**(cac/(RA+RB)**(1D0/3D0))*(RA+RB)**(10D0/3D0)*(cad+(RA+RB)**(1D0/3D0))) + cdelta = (cac+cad+(cac*cad)/(RA+RB)**(1D0/3D0))/(cad+(RA+RB)**(1D0/3D0)) + cLaa = (cab*comega*RB*(RA-3D0*cdelta*RA-9D0*RB-((-11D0+cdelta)*RA**2D0)/(RA+RB)))/9D0 + cLbb = (cab*comega*RA*(-9D0*RA+(RB*(RA-3D0*cdelta*RA-4D0*(-3D0+cdelta)*RB))/(RA+RB)))/9D0 + cLab = cab*comega*(((47D0-7D0*cdelta)*RA*RB)/9D0-(4D0*(RA+RB)**2D0)/3D0) + ec_lyp2 = -(caa*(cLaa*GA+cLab*GAB+cLbb*GB+cab*cae*comega*RA*RB*(RA**(8D0/3D0)+RB**(8D0/3D0))+(4D0*RA*RB)/(RA+RB+cad*(RA+RB)**(2D0/3D0)))) + endif + endif +end diff --git a/src/dft_utils_one_e/ec_scan.irp.f b/src/dft_utils_one_e/ec_scan.irp.f index 4807b89f..741129eb 100644 --- a/src/dft_utils_one_e/ec_scan.irp.f +++ b/src/dft_utils_one_e/ec_scan.irp.f @@ -37,7 +37,9 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) gama = 0.031091d0 ! correlation energy lsda1 call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) - + + ! correlation energy per particle + e_c_lsda1 = e_c_lsda1/rho xi = spin_d/rho rs = (cst_43 * pi * rho)**(-cst_13) s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) @@ -61,7 +63,12 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) ! interpolation function - fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph) + + if(cst_1alph.gt.0.d0)then + fc_alpha = dexp(-c_1c * alpha * inv_1alph) + else + fc_alpha = - d_c * dexp(c_2c * inv_1alph) + endif ! first part of the correlation energy e_c_1 = e_c_lsda1 + h1 @@ -82,15 +89,6 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1) end -double precision function step_f(x) - implicit none - double precision, intent(in) :: x - if(x.lt.0.d0)then - step_f = 0.d0 - else - step_f = 1.d0 - endif -end double precision function beta_rs(rs) implicit none @@ -98,3 +96,4 @@ double precision function beta_rs(rs) beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) end + diff --git a/src/dft_utils_one_e/ec_scan_2.irp.f b/src/dft_utils_one_e/ec_scan_2.irp.f new file mode 100644 index 00000000..4807b89f --- /dev/null +++ b/src/dft_utils_one_e/ec_scan_2.irp.f @@ -0,0 +1,100 @@ +double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) + include 'constants.include.F' + implicit none + double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2 + double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2 + double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0 + double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf + double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1 + double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0 + thr = 1.d-12 + nup = max(rho_a,thr) + ndo = max(rho_b,thr) + rho = nup + ndo + ec_scan = 0.d0 + if((rho).lt.thr)return + ! constants ... + rho_inv = 1.d0/rho + cst_13 = 1.d0/3.d0 + cst_23 = 2.d0 * cst_13 + cst_43 = 4.d0 * cst_13 + cst_53 = 5.d0 * cst_13 + cst_18 = 1.d0/8.d0 + cst_3pi2 = 3.d0 * pi*pi + drho2 = max(grad_rho_2,thr) + drho = dsqrt(drho2) + if((nup-ndo).gt.0.d0)then + spin_d = max(nup-ndo,thr) + else + spin_d = min(nup-ndo,-thr) + endif + c_1c = 0.64d0 + c_2c = 1.5d0 + d_c = 0.7d0 + b_1c = 0.0285764d0 + b_2c = 0.0889d0 + b_3c = 0.125541d0 + gama = 0.031091d0 + ! correlation energy lsda1 + call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) + + xi = spin_d/rho + rs = (cst_43 * pi * rho)**(-cst_13) + s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) + t_w = drho2 * cst_18 * rho_inv + ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53) + t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi + t_unif = max(t_unif,thr) + alpha = (tau - t_w)/t_unif + cst_1alph= 1.d0 - alpha + if(cst_1alph.gt.0.d0)then + cst_1alph= max(cst_1alph,thr) + else + cst_1alph= min(cst_1alph,-thr) + endif + inv_1alph= 1.d0/cst_1alph + phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23) + phi_3 = phi*phi*phi + t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0) + w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0 + a = beta_rs(rs) /(gama * w_1) + g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 + h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) + ! interpolation function + fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph) + ! first part of the correlation energy + e_c_1 = e_c_lsda1 + h1 + + dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43) + gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0) + e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs) + w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0 + beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0 + cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi + + x_inf = 0.128026d0 + f0 = -0.9d0 + g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0 + + h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf)) + e_c_0 = (e_c_lsda0 + h0) * gc_xi + + ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1) +end + +double precision function step_f(x) + implicit none + double precision, intent(in) :: x + if(x.lt.0.d0)then + step_f = 0.d0 + else + step_f = 1.d0 + endif +end + +double precision function beta_rs(rs) + implicit none + double precision, intent(in) ::rs + beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) + +end diff --git a/src/fci/class.irp.f b/src/fci/class.irp.f index 425691ae..b4a68ac2 100644 --- a/src/fci/class.irp.f +++ b/src/fci/class.irp.f @@ -1,10 +1,12 @@ BEGIN_PROVIDER [ logical, do_only_1h1p ] +&BEGIN_PROVIDER [ logical, do_only_cas ] &BEGIN_PROVIDER [ logical, do_ddci ] implicit none BEGIN_DOC ! In the FCI case, all those are always false END_DOC do_only_1h1p = .False. + do_only_cas = .False. do_ddci = .False. END_PROVIDER diff --git a/src/generators_cas/generators.irp.f b/src/generators_cas/generators.irp.f index c22eab51..b2f58202 100644 --- a/src/generators_cas/generators.irp.f +++ b/src/generators_cas/generators.irp.f @@ -55,6 +55,7 @@ END_PROVIDER nongen(inongen) = i endif enddo + ASSERT (m == N_det_generators) psi_det_sorted_gen(:,:,:N_det_generators) = psi_det_generators(:,:,:N_det_generators) psi_coef_sorted_gen(:N_det_generators, :) = psi_coef_generators(:N_det_generators, :) diff --git a/src/generators_fluid/NEED b/src/generators_fluid/NEED new file mode 100644 index 00000000..d3d4d2c7 --- /dev/null +++ b/src/generators_fluid/NEED @@ -0,0 +1 @@ +determinants diff --git a/src/generators_fluid/README.rst b/src/generators_fluid/README.rst new file mode 100644 index 00000000..e69de29b diff --git a/src/generators_fluid/extract_cas.irp.f b/src/generators_fluid/extract_cas.irp.f new file mode 100644 index 00000000..9cdaf27f --- /dev/null +++ b/src/generators_fluid/extract_cas.irp.f @@ -0,0 +1,23 @@ +subroutine extract_cas + implicit none + BEGIN_DOC + ! Replaces the total wave function by the normalized projection on the CAS. + END_DOC + + integer :: i,j,k + do k=1,N_states + do j=1,N_det_generators + psi_coef(j,k) = psi_coef_generators(j,k) + enddo + enddo + + do j=1,N_det_generators + do k=1,N_int + psi_det(k,1,j) = psi_det_generators(k,1,j) + psi_det(k,2,j) = psi_det_generators(k,2,j) + enddo + enddo + N_det = N_det_generators + + SOFT_TOUCH N_det psi_det psi_coef +end diff --git a/src/generators_fluid/generators.irp.f b/src/generators_fluid/generators.irp.f new file mode 100644 index 00000000..153ab605 --- /dev/null +++ b/src/generators_fluid/generators.irp.f @@ -0,0 +1,101 @@ +use bitmasks + +BEGIN_PROVIDER [ character*(32), generators_type] + implicit none + generators_type = trim("CAS") + +END_PROVIDER + +BEGIN_PROVIDER [ integer, N_det_generators ] + implicit none + BEGIN_DOC + ! Number of generator detetrminants + END_DOC + if(generators_type == "CAS")then + N_det_generators = N_det_generators_CAS + else if (generators_type == "HF")then + N_det_generators = N_det_generators_HF + else if (generators_type == "HF_SD")then + N_det_generators = N_det_generators_HF_SD + endif + N_det_generators = max(N_det_generators,1) + call write_int(6,N_det_generators,'Number of generators') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + + if(generators_type == "CAS")then + psi_det_generators(1:N_int,1:2,1:N_det_generators_CAS) = psi_det_generators_CAS(1:N_int,1:2,1:N_det_generators_CAS) + psi_coef_generators(1:N_det_generators_CAS,1:N_states) = psi_coef_generators_CAS(1:N_det_generators_CAS,1:N_states) + else if (generators_type == "HF")then + psi_det_generators(1:N_int,1:2,1:N_det_generators_HF) = psi_det_generators_HF(1:N_int,1:2,1:N_det_generators_HF) + psi_coef_generators(1:N_det_generators_HF,1:N_states) = psi_coef_generators_HF(1:N_det_generators_HF,1:N_states) + else if (generators_type == "HF_SD")then + psi_det_generators(1:N_int,1:2,1:N_det_generators_HF_SD) = psi_det_generators_HF_SD(1:N_int,1:2,1:N_det_generators_HF_SD) + psi_coef_generators(1:N_det_generators_HF_SD,1:N_states) = psi_coef_generators_HF_SD(1:N_det_generators_HF_SD,1:N_states) + endif + +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ] + + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + if(generators_type == "CAS")then + psi_det_sorted_gen = psi_det_sorted_gen_CAS + psi_coef_sorted_gen = psi_coef_sorted_gen_CAS + psi_det_sorted_gen_order = psi_det_sorted_gen_CAS_order + else if(generators_type == "HF")then + psi_det_sorted_gen = 0_bit_kind + psi_coef_sorted_gen = 0.d0 + psi_det_sorted_gen_order = 0 + else if(generators_type == "HF_SD")then + psi_det_sorted_gen = psi_det_sorted_gen_HF_SD + psi_coef_sorted_gen = psi_coef_sorted_gen_HF_SD + psi_det_sorted_gen_order = psi_det_sorted_gen_HF_SD_order + endif +END_PROVIDER + + +BEGIN_PROVIDER [integer, degree_max_generators] + implicit none + BEGIN_DOC +! Max degree of excitation (respect to HF) of the generators + END_DOC + integer :: i,degree + degree_max_generators = 0 + do i = 1, N_det_generators + call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int) + if(degree .gt. degree_max_generators)then + degree_max_generators = degree + endif + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer, size_select_max] + implicit none + BEGIN_DOC + ! Size of the select_max array + END_DOC + size_select_max = 10000 +END_PROVIDER + +BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ] + implicit none + BEGIN_DOC + ! Memo to skip useless selectors + END_DOC + select_max = huge(1.d0) +END_PROVIDER + diff --git a/src/generators_fluid/generators_cas.irp.f b/src/generators_fluid/generators_cas.irp.f new file mode 100644 index 00000000..b6d83e0a --- /dev/null +++ b/src/generators_fluid/generators_cas.irp.f @@ -0,0 +1,69 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators_CAS ] + implicit none + BEGIN_DOC + ! Number of generator detetrminants + END_DOC + integer :: i,k,l + logical :: good + integer, external :: number_of_holes,number_of_particles + call write_time(6) + N_det_generators_CAS = 0 + do i=1,N_det + good = ( number_of_holes(psi_det_sorted(1,1,i)) ==0).and.(number_of_particles(psi_det_sorted(1,1,i))==0 ) + if (good) then + N_det_generators_CAS += 1 + endif + enddo + N_det_generators_CAS = max(N_det_generators_CAS,1) + call write_int(6,N_det_generators_CAS,'Number of generators_CAS') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_CAS, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators_CAS, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen_CAS, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen_CAS, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_CAS_order, (psi_det_size) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the gen_CASerator is the + ! Hartree-Fock determinant + END_DOC + integer :: i, k, l, m + logical :: good + integer, external :: number_of_holes,number_of_particles + integer, allocatable :: nongen_CAS(:) + integer :: inongen_CAS + + allocate(nongen_CAS(N_det)) + + inongen_CAS = 0 + m=0 + do i=1,N_det + good = ( number_of_holes(psi_det_sorted(1,1,i)) ==0).and.(number_of_particles(psi_det_sorted(1,1,i))==0 ) + if (good) then + m = m+1 + psi_det_sorted_gen_CAS_order(i) = m + do k=1,N_int + psi_det_generators_CAS(k,1,m) = psi_det_sorted(k,1,i) + psi_det_generators_CAS(k,2,m) = psi_det_sorted(k,2,i) + enddo + psi_coef_generators_CAS(m,:) = psi_coef_sorted(i,:) + else + inongen_CAS += 1 + nongen_CAS(inongen_CAS) = i + endif + enddo + ASSERT (m == N_det_generators_CAS) + + psi_det_sorted_gen_CAS(:,:,:N_det_generators_CAS) = psi_det_generators_CAS(:,:,:N_det_generators_CAS) + psi_coef_sorted_gen_CAS(:N_det_generators_CAS, :) = psi_coef_generators_CAS(:N_det_generators_CAS, :) + do i=1,inongen_CAS + psi_det_sorted_gen_CAS_order(nongen_CAS(i)) = N_det_generators_CAS+i + psi_det_sorted_gen_CAS(:,:,N_det_generators_CAS+i) = psi_det_sorted(:,:,nongen_CAS(i)) + psi_coef_sorted_gen_CAS(N_det_generators_CAS+i, :) = psi_coef_sorted(nongen_CAS(i),:) + end do + +END_PROVIDER + diff --git a/src/generators_fluid/generators_hf.irp.f b/src/generators_fluid/generators_hf.irp.f new file mode 100644 index 00000000..d4d2e728 --- /dev/null +++ b/src/generators_fluid/generators_hf.irp.f @@ -0,0 +1,51 @@ + +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators_HF ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of generators is 1 : the + ! Hartree-Fock determinant + END_DOC + N_det_generators_HF = 1 +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_HF, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators_HF, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_generators_HF = 0_bit_kind + integer :: i,j + integer :: degree + + do i=1,N_int + psi_det_generators_HF(i,1,1) = HF_bitmask(i,1) + psi_det_generators_HF(i,2,1) = HF_bitmask(i,2) + enddo + + do j=1,N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,j),degree,N_int) + if (degree == 0) then + exit + endif + end do + + psi_det_generators_HF(:,:,1) = psi_det(:,:,j) + psi_coef_generators_HF(1,:) = 1.d0 + +END_PROVIDER + + BEGIN_PROVIDER [ integer , HF_index ] + implicit none + integer :: j,degree + do j=1,N_det + call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,j),degree,N_int) + if (degree == 0) then + HF_index = j + exit + endif + end do +END_PROVIDER diff --git a/src/generators_fluid/generators_hf_sd.irp.f b/src/generators_fluid/generators_hf_sd.irp.f new file mode 100644 index 00000000..9c13a5a0 --- /dev/null +++ b/src/generators_fluid/generators_hf_sd.irp.f @@ -0,0 +1,80 @@ + +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators_HF_SD ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of generators is 1 : the + ! Hartree-Fock determinant + END_DOC + N_det_generators_HF_SD = 0 + integer :: i,degree + double precision :: thr + double precision :: accu + accu = 0.d0 + thr = threshold_generators + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,i),degree,N_int) + if(degree.le.2.and. accu .le. thr )then + accu += psi_coef_sorted(i,1)**2 + N_det_generators_HF_SD += 1 + endif + enddo +!print*,'' +!print*,'N_det_generators_HF_SD = ',N_det_generators_HF_SD +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_HF_SD, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators_HF_SD, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen_HF_SD, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen_HF_SD, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_HF_SD_order, (psi_det_size) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_generators_HF_SD = 0_bit_kind + integer :: i,j,k + integer :: degree + double precision :: thr + double precision :: accu + integer, allocatable :: nongen(:) + integer :: inongen + + allocate(nongen(N_det)) + + thr = threshold_generators + + accu = 0.d0 + k = 0 + inongen = 0 + do j=1,N_det + call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,j),degree,N_int) + if(degree.le.2.and. accu.le.thr )then + accu += psi_coef_sorted(j,1)**2 + k += 1 + psi_det_sorted_gen_HF_SD_order(j) = k + do i = 1, N_int + psi_det_generators_HF_SD(i,1,k) = psi_det_sorted(i,1,j) + psi_det_generators_HF_SD(i,2,k) = psi_det_sorted(i,2,j) + enddo + do i = 1, N_states + psi_coef_generators_HF_SD(k,i) = psi_coef_sorted(j,i) + enddo + else + inongen += 1 + nongen(inongen) = j + endif + end do + + psi_det_sorted_gen_HF_SD(:,:,:N_det_generators_HF_SD) = psi_det_generators_HF_SD(:,:,:N_det_generators_HF_SD) + psi_coef_sorted_gen_HF_SD(:N_det_generators_HF_SD, :) = psi_coef_generators_HF_SD(:N_det_generators_HF_SD, :) + do i=1,inongen + psi_det_sorted_gen_HF_SD_order(nongen(i)) = N_det_generators_HF_SD+i + psi_det_sorted_gen_HF_SD(:,:,N_det_generators_HF_SD+i) = psi_det_sorted(:,:,nongen(i)) + psi_coef_sorted_gen_HF_SD(N_det_generators_HF_SD+i, :) = psi_coef_sorted(nongen(i),:) + end do + +END_PROVIDER + diff --git a/src/mo_two_e_ints/EZFIO.cfg b/src/mo_two_e_ints/EZFIO.cfg index 57681638..bec74552 100644 --- a/src/mo_two_e_ints/EZFIO.cfg +++ b/src/mo_two_e_ints/EZFIO.cfg @@ -11,24 +11,3 @@ interface: ezfio,provider,ocaml default: 1.e-15 ezfio_name: threshold_mo -[no_vvvv_integrals] -type: logical -doc: If `True`, computes all integrals except for the integrals having 4 virtual indices -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_vvvv_integrals - -[no_ivvv_integrals] -type: logical -doc: Can be switched on only if `no_vvvv_integrals` is `True`, then does not compute the integrals with 3 virtual indices and 1 belonging to the core inactive active orbitals -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_ivvv_integrals - -[no_vvv_integrals] -type: logical -doc: Can be switched on only if `no_vvvv_integrals` is `True`, then does not compute the integrals with 3 virtual orbitals -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_vvv_integrals - diff --git a/src/mo_two_e_ints/four_idx_novvvv.irp.f b/src/mo_two_e_ints/four_idx_novvvv.irp.f new file mode 100644 index 00000000..054d0a35 --- /dev/null +++ b/src/mo_two_e_ints/four_idx_novvvv.irp.f @@ -0,0 +1,180 @@ +BEGIN_PROVIDER [ logical, no_vvvv_integrals ] + implicit none + BEGIN_DOC +! If `True`, computes all integrals except for the integrals having 3 or 4 virtual indices + END_DOC + + no_vvvv_integrals = .False. +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_coef_novirt, (ao_num,n_core_inact_act_orb) ] + implicit none + BEGIN_DOC + ! MO coefficients without virtual MOs + END_DOC + integer :: j,jj + + do j=1,n_core_inact_act_orb + jj = list_core_inact_act(j) + mo_coef_novirt(:,j) = mo_coef(:,jj) + enddo + +END_PROVIDER + +subroutine ao_to_mo_novirt(A_ao,LDA_ao,A_mo,LDA_mo) + implicit none + BEGIN_DOC + ! Transform A from the |AO| basis to the |MO| basis excluding virtuals + ! + ! $C^\dagger.A_{ao}.C$ + END_DOC + integer, intent(in) :: LDA_ao,LDA_mo + double precision, intent(in) :: A_ao(LDA_ao,ao_num) + double precision, intent(out) :: A_mo(LDA_mo,n_core_inact_act_orb) + double precision, allocatable :: T(:,:) + + allocate ( T(ao_num,n_core_inact_act_orb) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + + call dgemm('N','N', ao_num, n_core_inact_act_orb, ao_num, & + 1.d0, A_ao,LDA_ao, & + mo_coef_novirt, size(mo_coef_novirt,1), & + 0.d0, T, size(T,1)) + + call dgemm('T','N', n_core_inact_act_orb, n_core_inact_act_orb, ao_num,& + 1.d0, mo_coef_novirt,size(mo_coef_novirt,1), & + T, ao_num, & + 0.d0, A_mo, size(A_mo,1)) + + deallocate(T) +end + + +subroutine four_idx_novvvv + use map_module + implicit none + BEGIN_DOC + ! Retransform MO integrals for next CAS-SCF step + END_DOC + integer :: i,j,k,l,n_integrals + double precision, allocatable :: f(:,:,:), f2(:,:,:), d(:,:), T(:,:,:,:), T2(:,:,:,:) + double precision, external :: get_ao_two_e_integral + integer(key_kind), allocatable :: idx(:) + real(integral_kind), allocatable :: values(:) + + integer :: p,q,r,s + double precision :: c + allocate( T(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) , & + T2(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) ) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(mo_num,ao_num,T,n_core_inact_act_orb, mo_coef_transp, & + !$OMP mo_integrals_threshold,mo_coef,mo_integrals_map, & + !$OMP list_core_inact_act,T2,ao_integrals_map) & + !$OMP PRIVATE(i,j,k,l,p,q,r,s,idx,values,n_integrals, & + !$OMP f,f2,d,c) + allocate(f(ao_num,ao_num,ao_num), f2(ao_num,ao_num,ao_num), d(mo_num,mo_num), & + idx(mo_num*mo_num), values(mo_num*mo_num) ) + + ! + !$OMP DO + do s=1,ao_num + do r=1,ao_num + do q=1,ao_num + do p=1,r + f (p,q,r) = get_ao_two_e_integral(p,q,r,s,ao_integrals_map) + f (r,q,p) = f(p,q,r) + enddo + enddo + enddo + do r=1,ao_num + do q=1,ao_num + do p=1,ao_num + f2(p,q,r) = f(p,r,q) + enddo + enddo + enddo + ! f (p,q,r) = + ! f2(p,q,r) = + + do r=1,ao_num + call ao_to_mo_novirt(f (1,1,r),size(f ,1),T (1,1,r,s),size(T,1)) + call ao_to_mo_novirt(f2(1,1,r),size(f2,1),T2(1,1,r,s),size(T,1)) + enddo + ! T (i,j,p,q) = + ! T2(i,j,p,q) = + + enddo + !$OMP END DO + + !$OMP DO + do j=1,n_core_inact_act_orb + do i=1,n_core_inact_act_orb + do s=1,ao_num + do r=1,ao_num + f (r,s,1) = T (i,j,r,s) + f2(r,s,1) = T2(i,j,r,s) + enddo + enddo + call ao_to_mo(f ,size(f ,1),d,size(d,1)) + n_integrals = 0 + do l=1,mo_num + do k=1,mo_num + n_integrals+=1 + call two_e_integrals_index(list_core_inact_act(i),list_core_inact_act(j),k,l,idx(n_integrals)) + values(n_integrals) = d(k,l) + enddo + enddo + call map_append(mo_integrals_map, idx, values, n_integrals) + + call ao_to_mo(f2,size(f2,1),d,size(d,1)) + n_integrals = 0 + do l=1,mo_num + do k=1,mo_num + n_integrals+=1 + call two_e_integrals_index(list_core_inact_act(i),k,list_core_inact_act(j),l,idx(n_integrals)) + values(n_integrals) = d(k,l) + enddo + enddo + call map_append(mo_integrals_map, idx, values, n_integrals) + enddo + enddo + !$OMP END DO + deallocate(f,f2,d,idx,values) + + !$OMP END PARALLEL + + deallocate(T,T2) + + + call map_sort(mo_integrals_map) + call map_unique(mo_integrals_map) + call map_shrink(mo_integrals_map,real(mo_integrals_threshold,integral_kind)) + +end + +subroutine four_idx_novvvv2 + use bitmasks + implicit none + integer :: i + integer(bit_kind) :: mask_ijkl(N_int,4) + + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = full_ijkl_bitmask_4(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,4) = full_ijkl_bitmask_4(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + +end diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index fccf22a6..a9983e51 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -22,16 +22,13 @@ end BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] use map_module implicit none - integer(bit_kind) :: mask_ijkl(N_int,4) - integer(bit_kind) :: mask_ijk(N_int,3) - BEGIN_DOC ! If True, the map of MO two-electron integrals is provided END_DOC + integer(bit_kind) :: mask_ijkl(N_int,4) + integer(bit_kind) :: mask_ijk(N_int,3) + double precision :: cpu_1, cpu_2, wall_1, wall_2 - ! The following line avoids a subsequent crash when the memory used is more - ! than half of the virtual memory, due to a fork in zcat when reading arrays - ! with EZFIO PROVIDE mo_class mo_two_e_integrals_in_map = .True. @@ -49,106 +46,28 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] print *, '---------------------------------' print *, '' + call wall_time(wall_1) + call cpu_time(cpu_1) + if(no_vvvv_integrals)then - integer :: i,j,k,l - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 4 - ! - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 2 (virt) ^2 - ! = J_iv - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = virt_bitmask(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - - ! (core+inact+act) ^ 2 (virt) ^2 - ! = (iv|iv) - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = virt_bitmask(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! - if(.not.no_vvv_integrals)then - print*, '' - print*, ' and ' - do i = 1,N_int - mask_ijk(i,1) = virt_bitmask(i,1) - mask_ijk(i,2) = virt_bitmask(i,1) - mask_ijk(i,3) = virt_bitmask(i,1) - enddo - call add_integrals_to_map_three_indices(mask_ijk) - endif - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 3 (virt) ^1 - ! - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 1 (virt) ^3 - ! - if(.not.no_ivvv_integrals)then - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = virt_bitmask(i,1) - mask_ijkl(i,3) = virt_bitmask(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map_no_exit_34(mask_ijkl) - endif - + call four_idx_novvvv else call add_integrals_to_map(full_ijkl_bitmask_4) - -! call four_index_transform_zmq(ao_integrals_map,mo_integrals_map, & -! mo_coef, size(mo_coef,1), & -! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & -! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) -! -! call four_index_transform_block(ao_integrals_map,mo_integrals_map, & -! mo_coef, size(mo_coef,1), & -! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & -! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) -! -! call four_index_transform(ao_integrals_map,mo_integrals_map, & -! mo_coef, size(mo_coef,1), & -! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & -! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) - - integer*8 :: get_mo_map_size, mo_map_size - mo_map_size = get_mo_map_size() - - print*,'Molecular integrals provided' endif + + call wall_time(wall_2) + call cpu_time(cpu_2) + + integer*8 :: get_mo_map_size, mo_map_size + mo_map_size = get_mo_map_size() + + double precision, external :: map_mb + print*,'Molecular integrals provided:' + print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' + print*,' Number of MO integrals: ', mo_map_size + print*,' cpu time :',cpu_2 - cpu_1, 's' + print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' + if (write_mo_two_e_integrals.and.mpi_master) then call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) @@ -185,7 +104,7 @@ subroutine add_integrals_to_map(mask_ijkl) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - double precision :: map_mb + double precision, external :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 @@ -201,10 +120,6 @@ subroutine add_integrals_to_map(mask_ijkl) call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int ) call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int ) - character*(2048) :: output(1) - print *, 'i' - call bitstring_to_str( output(1), mask_ijkl(1,1), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,1)) @@ -213,9 +128,6 @@ subroutine add_integrals_to_map(mask_ijkl) return endif - print*, 'j' - call bitstring_to_str( output(1), mask_ijkl(1,2), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,2)) @@ -224,9 +136,6 @@ subroutine add_integrals_to_map(mask_ijkl) return endif - print*, 'k' - call bitstring_to_str( output(1), mask_ijkl(1,3), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,3)) @@ -235,9 +144,6 @@ subroutine add_integrals_to_map(mask_ijkl) return endif - print*, 'l' - call bitstring_to_str( output(1), mask_ijkl(1,4), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,4)) @@ -247,14 +153,12 @@ subroutine add_integrals_to_map(mask_ijkl) endif size_buffer = min(ao_num*ao_num*ao_num,16000000) - print*, 'Providing the molecular integrals ' print*, 'Buffers : ', 8.*(mo_num*(n_j)*(n_k+1) + mo_num+& ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' - call wall_time(wall_1) - call cpu_time(cpu_1) double precision :: accu_bis accu_bis = 0.d0 + call wall_time(wall_1) !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & !$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,& @@ -452,12 +356,6 @@ subroutine add_integrals_to_map(mask_ijkl) deallocate(list_ijkl) - print*,'Molecular integrals provided:' - print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' - print*,' Number of MO integrals: ', mo_map_size - print*,' cpu time :',cpu_2 - cpu_1, 's' - print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' - end @@ -504,10 +402,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) call bitstring_to_list( mask_ijk(1,1), list_ijkl(1,1), n_i, N_int ) call bitstring_to_list( mask_ijk(1,2), list_ijkl(1,2), n_j, N_int ) call bitstring_to_list( mask_ijk(1,3), list_ijkl(1,3), n_k, N_int ) - character*(2048) :: output(1) - print*, 'i' - call bitstring_to_str( output(1), mask_ijk(1,1), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijk(i,1)) @@ -516,9 +410,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) return endif - print*, 'j' - call bitstring_to_str( output(1), mask_ijk(1,2), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijk(i,2)) @@ -527,9 +418,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) return endif - print*, 'k' - call bitstring_to_str( output(1), mask_ijk(1,3), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijk(i,3)) diff --git a/src/nuclei/atomic_radii.irp.f b/src/nuclei/atomic_radii.irp.f index 439b5cec..c189effd 100644 --- a/src/nuclei/atomic_radii.irp.f +++ b/src/nuclei/atomic_radii.irp.f @@ -50,7 +50,58 @@ BEGIN_PROVIDER [ double precision, slater_bragg_radii, (0:100)] slater_bragg_radii(33) = 1.15d0 slater_bragg_radii(34) = 1.15d0 slater_bragg_radii(35) = 1.15d0 - slater_bragg_radii(36) = 1.15d0 + slater_bragg_radii(36) = 1.10d0 + + slater_bragg_radii(37) = 2.35d0 + slater_bragg_radii(38) = 2.00d0 + slater_bragg_radii(39) = 1.80d0 + slater_bragg_radii(40) = 1.55d0 + slater_bragg_radii(41) = 1.45d0 + slater_bragg_radii(42) = 1.45d0 + slater_bragg_radii(43) = 1.35d0 + slater_bragg_radii(44) = 1.30d0 + slater_bragg_radii(45) = 1.35d0 + slater_bragg_radii(46) = 1.40d0 + slater_bragg_radii(47) = 1.60d0 + slater_bragg_radii(48) = 1.55d0 + slater_bragg_radii(49) = 1.55d0 + slater_bragg_radii(50) = 1.45d0 + slater_bragg_radii(51) = 1.45d0 + slater_bragg_radii(52) = 1.40d0 + slater_bragg_radii(53) = 1.40d0 + slater_bragg_radii(54) = 1.40d0 + slater_bragg_radii(55) = 2.60d0 + slater_bragg_radii(56) = 2.15d0 + slater_bragg_radii(57) = 1.95d0 + slater_bragg_radii(58) = 1.85d0 + slater_bragg_radii(59) = 1.85d0 + slater_bragg_radii(60) = 1.85d0 + slater_bragg_radii(61) = 1.85d0 + slater_bragg_radii(62) = 1.85d0 + slater_bragg_radii(63) = 1.85d0 + slater_bragg_radii(64) = 1.80d0 + slater_bragg_radii(65) = 1.75d0 + slater_bragg_radii(66) = 1.75d0 + slater_bragg_radii(67) = 1.75d0 + slater_bragg_radii(68) = 1.75d0 + slater_bragg_radii(69) = 1.75d0 + slater_bragg_radii(70) = 1.75d0 + slater_bragg_radii(71) = 1.75d0 + slater_bragg_radii(72) = 1.55d0 + slater_bragg_radii(73) = 1.45d0 + slater_bragg_radii(74) = 1.35d0 + slater_bragg_radii(75) = 1.30d0 + slater_bragg_radii(76) = 1.30d0 + slater_bragg_radii(77) = 1.35d0 + slater_bragg_radii(78) = 1.35d0 + slater_bragg_radii(79) = 1.35d0 + slater_bragg_radii(80) = 1.50d0 + slater_bragg_radii(81) = 1.90d0 + slater_bragg_radii(82) = 1.75d0 + slater_bragg_radii(83) = 1.60d0 + slater_bragg_radii(84) = 1.90d0 + slater_bragg_radii(85) = 1.50d0 + slater_bragg_radii(86) = 1.50d0 END_PROVIDER diff --git a/src/selectors_full/selectors.irp.f b/src/selectors_full/selectors.irp.f index 4e14d65a..0531f731 100644 --- a/src/selectors_full/selectors.irp.f +++ b/src/selectors_full/selectors.irp.f @@ -38,35 +38,18 @@ END_PROVIDER END_DOC integer :: i,k -! if (threshold_selectors == 1.d0) then -! -! do i=1,N_det_selectors -! do k=1,N_int -! psi_selectors(k,1,i) = psi_det(k,1,i) -! psi_selectors(k,2,i) = psi_det(k,2,i) -! enddo -! 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 k=1,N_int + 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 - do k=1,N_int - 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 + psi_selectors_coef(i,k) = psi_coef_sorted(i,k) enddo + enddo -! endif END_PROVIDER diff --git a/src/tools/print_wf.irp.f b/src/tools/print_wf.irp.f index 01fc8948..3323b46e 100644 --- a/src/tools/print_wf.irp.f +++ b/src/tools/print_wf.irp.f @@ -51,7 +51,7 @@ subroutine routine if(degree == 0)then print*,'Reference determinant ' call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,h00) - else + else if(degree .le. 2)then call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii) call i_H_j(psi_det(1,1,1),psi_det(1,1,i),N_int,hij) delta_e = hii - h00 diff --git a/src/two_body_rdm/NEED b/src/two_body_rdm/NEED new file mode 100644 index 00000000..711fbf96 --- /dev/null +++ b/src/two_body_rdm/NEED @@ -0,0 +1 @@ +davidson_undressed diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst new file mode 100644 index 00000000..978240c9 --- /dev/null +++ b/src/two_body_rdm/README.rst @@ -0,0 +1,8 @@ +============ +two_body_rdm +============ + +Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as +arrays, with pysicists notation, consistent with the two-electron integrals in the +MO basis. + diff --git a/src/two_body_rdm/ab_only_routines.irp.f b/src/two_body_rdm/ab_only_routines.irp.f new file mode 100644 index 00000000..fb3c421c --- /dev/null +++ b/src/two_body_rdm/ab_only_routines.irp.f @@ -0,0 +1,402 @@ + + subroutine two_rdm_ab_nstates(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS + ! + ! 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,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,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 two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,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 two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the alpha/beta part of the two-body density matrix + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call two_rdm_ab_nstates_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call two_rdm_ab_nstates_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call two_rdm_ab_nstates_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call two_rdm_ab_nstates_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + 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 + BEGIN_TEMPLATE + + 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 + implicit none + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + double precision :: hij, sij + 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, nmax + integer*8 :: k8 + + 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 + + ! Alpha/Beta double excitations + ! ============================= + + 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) + + 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 + ! ----------------------- + + 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) + !!!!!!!!!!!!!!!!!! ALPHA BETA + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + + + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! 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) + + 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) + !!!! MONO SPIN + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + + enddo + + + !! Compute Hij for all alpha doubles + !! ---------------------------------- + ! + !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) + + ! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + + ! 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) + + ! 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) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + enddo + ! + !! Compute Hij for all beta doubles + !! ---------------------------------- + ! + !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) + + ! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + ! l_a = psi_bilinear_matrix_transp_order(l_b) + ! ASSERT (l_a <= N_det) + + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + ! 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_H_mat_elem_erf, diag_S_mat_elem + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_two_rdm_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4) + + end do + deallocate(buffer, singles_a, singles_b, doubles, idx) + + end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f new file mode 100644 index 00000000..fa036e6a --- /dev/null +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -0,0 +1,442 @@ +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 + implicit none + BEGIN_DOC + ! Computes the alpha/alpha, beta/beta and alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS + ! + ! 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,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,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 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) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + + +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 + 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,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + 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) + 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) + 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) + 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 + 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 + + BEGIN_TEMPLATE + +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 + implicit none + BEGIN_DOC + ! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$ + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + + 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 + + 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 + ! ============================= + + 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 + ! ----------------------- + + 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) + !call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + enddo + + 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) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the alpha/alpha part for single excitations + call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + 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) + + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + enddo + + + ! 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) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the beta /beta part for single excitations + call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + 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) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + + enddo + + + ! 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) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) + + 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 + diff --git a/src/two_body_rdm/all_states_2_rdm.irp.f b/src/two_body_rdm/all_states_2_rdm.irp.f new file mode 100644 index 00000000..bc503223 --- /dev/null +++ b/src/two_body_rdm/all_states_2_rdm.irp.f @@ -0,0 +1,83 @@ + + + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! all_states_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 1 + all_states_act_two_rdm_alpha_alpha_mo = 0.D0 + 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 + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! all_states_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 2 + all_states_act_two_rdm_beta_beta_mo = 0.d0 + 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 + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! = + 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 all_states_act_two_rdm_alpha_beta_mo ' + ispin = 3 + print*,'ispin = ',ispin + all_states_act_two_rdm_alpha_beta_mo = 0.d0 + 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 + + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! all_states_act_two_rdm_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} all_states_act_two_rdm_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 + all_states_act_two_rdm_spin_trace_mo = 0.d0 + integer :: i + + 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 + diff --git a/src/two_body_rdm/all_states_routines.irp.f b/src/two_body_rdm/all_states_routines.irp.f new file mode 100644 index 00000000..8f40f32a --- /dev/null +++ b/src/two_body_rdm/all_states_routines.irp.f @@ -0,0 +1,495 @@ +subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,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 + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + double precision, intent(in) :: u_0(sze,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_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) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + +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 + 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 + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + double precision, intent(in) :: u_t(N_st,N_det) + + integer :: k + + PROVIDE N_int + + select case (N_int) + case (1) + 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) + 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) + 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) + 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 + 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 + + + + + BEGIN_TEMPLATE +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 + 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 + ! 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) + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + + 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,allocatable :: c_contrib(:) + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + integer(bit_kind) :: orb_bitmask($N_int) + 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_dm_nstates_work' + print*,'ispin = ',ispin + stop + endif + + PROVIDE N_int + + call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) + + 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 + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab),c_contrib(N_st)) + + 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_contrib = 0.d0 + do l= 1, N_st + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + 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_contrib = 0.d0 + do l= 1, N_st + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(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_all_states(tmp_det, tmp_det2,c_contrib,N_st,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_all_states(tmp_det,tmp_det2,c_contrib,N_st,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_contrib = 0.d0 + do l= 1, N_st + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) += c_1(l) * c_2(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_contrib,N_st,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_contrib = 0.d0 + do l= 1, N_st + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(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_all_states(tmp_det, tmp_det2,c_contrib,N_st,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_all_states(tmp_det, tmp_det2,c_contrib,N_st,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_contrib = 0.d0 + do l= 1, N_st + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_contrib,N_st,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_contrib = 0.d0 + do l = 1, N_st + c_1(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_1(l) + enddo + + call orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + + 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 + diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f new file mode 100644 index 00000000..d441e1df --- /dev/null +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -0,0 +1,87 @@ + + + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_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_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! = + 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_alpha_alpha_mo = 0.D0 + 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 + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_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_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! = + 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_beta_beta_mo = 0.d0 + 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 + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_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_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! = + 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_alpha_beta_mo ' + ispin = 3 + print*,'ispin = ',ispin + state_av_act_two_rdm_alpha_beta_mo = 0.d0 + 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 + + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC +! state_av_act_two_rdm_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_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_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(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) + print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0 + END_PROVIDER + diff --git a/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f b/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f new file mode 100644 index 00000000..386e2a54 --- /dev/null +++ b/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f @@ -0,0 +1,85 @@ + + 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 +! = + 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 +! = + 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 +! = + 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 + diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f new file mode 100644 index 00000000..a8684185 --- /dev/null +++ b/src/two_body_rdm/orb_range_routines.irp.f @@ -0,0 +1,498 @@ +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 + 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 + integer, intent(in) :: list_orb_reverse(mo_num) + 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_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) + + 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_work(big_array,dim1,norb,list_orb,list_orb_reverse,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 + integer, intent(in) :: list_orb_reverse(mo_num) + 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_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) + 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) + 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) + 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 + 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 + + + + + BEGIN_TEMPLATE +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 + 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 + integer, intent(in) :: list_orb_reverse(mo_num) + 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) + 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_work' + print*,'ispin = ',ispin + stop + endif + + + PROVIDE N_int + + call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) + + 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 + ! ============================= + + 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 + call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + 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_beta_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 orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + + 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 + diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f new file mode 100644 index 00000000..b6e59540 --- /dev/null +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -0,0 +1,568 @@ +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 + use omp_lib + 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(omp_lock_kind) :: lock_2rdm + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b + integer :: krow, kcol + integer :: lrow, lcol + 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 + 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 + + + PROVIDE N_int + + call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) + sze_buff = norb ** 3 + 6 * norb + 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 + call omp_init_lock(lock_2rdm) + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson elec_alpha_num + !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + !$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,& + !$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,elec_alpha_num, & + !$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, state_weights, dim1, & + !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) & + !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, c_2, & + !$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, nkeys, keys, values, c_average) + + ! 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,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + else if (spin_trace)then + ! TWO contributions + if (nkeys+2 .ge. size(values)) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + 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 + if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + ! increment the alpha/alpha part for single excitations + if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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 + if (nkeys+4 .ge. sze_buff) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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 + if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + ! increment the beta /beta part for single excitations + if (nkeys+4 * elec_alpha_num .ge. sze_buff) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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 + if (nkeys+4 .ge. sze_buff) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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,nkeys,dim1,big_array,lock_2rdm) + 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,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + + end do + !$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values) + !$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + + +subroutine update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + use omp_lib + implicit none + integer, intent(in) :: nkeys,dim1 + integer, intent(in) :: keys(4,nkeys) + double precision, intent(in) :: values(nkeys) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + + integer(omp_lock_kind),intent(inout):: lock_2rdm + integer :: i,h1,h2,p1,p2 + call omp_set_lock(lock_2rdm) + 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 + call omp_unset_lock(lock_2rdm) + +end + diff --git a/src/two_body_rdm/routines_compute_2rdm.irp.f b/src/two_body_rdm/routines_compute_2rdm.irp.f new file mode 100644 index 00000000..112d2e36 --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm.irp.f @@ -0,0 +1,269 @@ + + + subroutine diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + enddo + end + + + subroutine diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of ALL THREE two body rdm IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_ab(h1,h1,h2,h2,istate) += c_1_bis + enddo + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array_aa(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis + big_array_aa(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis + enddo + enddo + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_bb(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis + big_array_bb(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis + enddo + enddo + enddo + end + + + subroutine off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate) +! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + 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 + 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 (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end + + subroutine off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + 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 + 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 (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + + big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + return + endif + end + + subroutine off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + 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 + 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 (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + + big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end + + + subroutine off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) +!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + + big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) +!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + + big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + enddo + end + diff --git a/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f b/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f new file mode 100644 index 00000000..7606e353 --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f @@ -0,0 +1,660 @@ + + subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals + END_DOC + implicit none + integer, intent(in) :: dim1,N_st + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_st + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h2,h1,h2,istate) += c_1(istate) + enddo + enddo + enddo + end + + + subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + 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 +! +! big_array(dim1,dim1,dim1,dim1,N_st) 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 + END_DOC + implicit none + integer, intent(in) :: dim1,N_st,ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + + 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 istate = 1, N_st + 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) + big_array(h1,h2,h1,h2,istate) += c_1(istate) + enddo + enddo + enddo + else if (alpha_alpha)then + do istate = 1, N_st + 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) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + enddo + enddo + enddo + else if (beta_beta)then + do istate = 1, N_st + 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) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + enddo + enddo + enddo + else if(spin_trace)then + ! 0.5 * (alpha beta + beta alpha) + do istate = 1, N_st + 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) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h2,h1,h2,h1,istate) += 0.5d0 * c_1(istate) + 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) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + 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) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + enddo + enddo + enddo + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_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/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,N_st) 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,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + 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(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + h2 = exc(1,1,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + p2 = exc(1,2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) + do istate = 1, N_st + if(alpha_beta)then + big_array(h1,h2,p1,p2,istate) += c_1(istate) * phase + else if(spin_trace)then + big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase + big_array(p1,p2,h1,h2,istate) += 0.5d0 * c_1(istate) * phase + endif + enddo + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_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,N_st) 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,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + + 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 + do istate = 1, N_st + 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,istate) += c_1(istate) * 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,istate) += c_1(istate) * phase + enddo + endif + enddo + 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 istate = 1, N_st + 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,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + enddo + 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 istate = 1, N_st + 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,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + enddo + enddo + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_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,N_st) 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,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + + 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 istate = 1, N_st + 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,istate) += 0.5d0 * c_1(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase + + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase + enddo + enddo + else + return + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_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,N_st) 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,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + + + 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_st + 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,istate) += 0.5d0 * c_1(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase + + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase + enddo + enddo + endif + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_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,N_st) 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,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + + 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_st + big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase + big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate) * phase + + big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate) * phase + enddo + endif + end + + subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_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,N_st) 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,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + 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(N_st) + + 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) + do istate = 1, N_st + if(beta_beta.or.spin_trace)then + big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate)* phase + big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate)* phase + + big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate)* phase + big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate)* phase + endif + enddo + end + diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f new file mode 100644 index 00000000..52cccbf3 --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -0,0 +1,670 @@ + + subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,orb_bitmask) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals +! c_1 is supposed to be a scalar quantity, such as state averaged coef + END_DOC + implicit none + integer, intent(in) :: dim1 + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + 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 + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2 + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h2,h1,h2) += c_1 + enddo + enddo + end + + + subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + 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 +! +! 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 + END_DOC + implicit none + integer, intent(in) :: dim1,ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + 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 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2 + 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 + +!print*,'ahah' +!call debug_det(det_1_act,N_int) +!pause + 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 + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + 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) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += c_1 + enddo + enddo + else if (alpha_alpha)then + do i = 1, n_occ_ab(1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(1) + i2 = occ(j,1) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + else if (beta_beta)then + do i = 1, n_occ_ab(2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + else if(spin_trace)then + ! 0.5 * (alpha beta + beta alpha) + do i = 1, n_occ_ab(1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 ) + big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 ) + enddo + enddo + !stop + do i = 1, n_occ_ab(1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(1) + i2 = occ(j,1) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + do i = 1, n_occ_ab(2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_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/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 == 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 :: i,j,h1,h2,p1,p2 + 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 +!print*,'' +!do i = 1, mo_num +! print*,'list_orb',i,list_orb_reverse(i) +!enddo + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) +!print*,'h1',h1 + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) +!print*,'passed h1 = ',h1 + h2 = exc(1,1,2) +!print*,'h2',h2 + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) +!print*,'passed h2 = ',h2 + p1 = exc(1,2,1) +!print*,'p1',p1 + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) +!print*,'passed p1 = ',p1 + p2 = exc(1,2,2) +!print*,'p2',p2 + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) +!print*,'passed p2 = ',p2 + if(alpha_beta)then + big_array(h1,h2,p1,p2) += c_1 * phase + else if(spin_trace)then + big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase + big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase + !print*,'h1,h2,p1,p2',h1,h2,p1,p2 + !print*,'',big_array(h1,h2,p1,p2) + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_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,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,big_array,dim1,orb_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,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,big_array,dim1,orb_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,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 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 + endif + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_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 + 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 + 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 + + subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_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 + 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 + diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f new file mode 100644 index 00000000..0ba934d7 --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f @@ -0,0 +1,807 @@ + 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 + 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 + 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_diag_single_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 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) :: 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 :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + endif + else if(spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + !print*,'****************' + !print*,'****************' + !print*,'h1,p1',h1,p1 + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + ! print*,'h2 = ',h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + endif + endif + end + + subroutine orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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) :: 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 :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + else + return + endif + endif + end + + subroutine orb_range_off_diag_single_to_two_rdm_bb_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 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) :: 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 :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + endif + endif + end + + + subroutine orb_range_off_diag_double_to_two_rdm_aa_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/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) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + 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 + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(alpha_alpha.or.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) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end + + subroutine orb_range_off_diag_double_to_two_rdm_bb_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 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) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + 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 + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(beta_beta.or.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) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end + diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f new file mode 100644 index 00000000..c162f365 --- /dev/null +++ b/src/two_body_rdm/two_rdm.irp.f @@ -0,0 +1,62 @@ + BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta(i,j,k,l) = + ! 1 1 2 2 = chemist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: dim1,dim2,dim3,dim4 + double precision :: cpu_0,cpu_1 + dim1 = mo_num + dim2 = mo_num + dim3 = mo_num + dim4 = mo_num + two_rdm_alpha_beta_mo = 0.d0 + two_rdm_alpha_alpha_mo= 0.d0 + two_rdm_beta_beta_mo = 0.d0 + print*,'providing two_rdm_alpha_beta ...' + call wall_time(cpu_0) + 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) + print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) + +END_PROVIDER + + + BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = + ! 1 2 1 2 = physicist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: i,j,k,l,istate + double precision :: cpu_0,cpu_1 + two_rdm_alpha_beta_mo_physicist = 0.d0 + print*,'providing two_rdm_alpha_beta_mo_physicist ...' + call wall_time(cpu_0) + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + ! 1 2 1 2 1 1 2 2 + two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate) + two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate) + two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate) + enddo + enddo + enddo + enddo + enddo + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + +END_PROVIDER +