From 5cb411d364f55b7407cef2c84f2219e591aefd96 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Jun 2019 09:39:05 +0200 Subject: [PATCH 01/28] Add energy components --- src/tools/print_ci_vectors.irp.f | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tools/print_ci_vectors.irp.f b/src/tools/print_ci_vectors.irp.f index 9ba06d9a..97dfdc0b 100644 --- a/src/tools/print_ci_vectors.irp.f +++ b/src/tools/print_ci_vectors.irp.f @@ -24,6 +24,7 @@ subroutine routine implicit none integer :: i,k integer :: degree + call print_energy_components do i = 1, N_det print *, 'Determinant ', i call debug_det(psi_det(1,1,i),N_int) From 9717223a4da917ad6f04b50aaf967fcd51208394 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Jun 2019 09:44:01 +0200 Subject: [PATCH 02/28] Fixed beta_rs --- src/dft_utils_one_e/ec_scan.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dft_utils_one_e/ec_scan.irp.f b/src/dft_utils_one_e/ec_scan.irp.f index 7a4b587b..4807b89f 100644 --- a/src/dft_utils_one_e/ec_scan.irp.f +++ b/src/dft_utils_one_e/ec_scan.irp.f @@ -95,6 +95,6 @@ end double precision function beta_rs(rs) implicit none double precision, intent(in) ::rs - beta_rs(rs) = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) + beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) end From 72f920e1119b5cb271191420364e0a6be229d55a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Jun 2019 19:21:01 +0200 Subject: [PATCH 03/28] Update do_single_excitation --- ocaml/qp_tunnel.ml | 6 +++ src/determinants/create_excitations.irp.f | 60 ++++++++++++++++++----- src/zmq/utils.irp.f | 3 +- 3 files changed, 56 insertions(+), 13 deletions(-) diff --git a/ocaml/qp_tunnel.ml b/ocaml/qp_tunnel.ml index c35a2bac..dee01980 100644 --- a/ocaml/qp_tunnel.ml +++ b/ocaml/qp_tunnel.ml @@ -363,6 +363,12 @@ let () = |> Zmq.Socket.send socket_in in + Printf.printf "On remote hosts, create ssh tunnel using: +ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s\n%!" + (port ) localhost (localport ) + (port+1) localhost (localport+1) + (port+9) localhost (localport+9) + (Unix.gethostname ()); Printf.printf "Ready\n%!"; while !run_status do diff --git a/src/determinants/create_excitations.irp.f b/src/determinants/create_excitations.irp.f index ddb9ae0f..cec87901 100644 --- a/src/determinants/create_excitations.irp.f +++ b/src/determinants/create_excitations.irp.f @@ -12,6 +12,7 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok) integer(bit_kind), intent(inout) :: key_in(N_int,2) integer, intent(out) :: i_ok integer :: k,j,i + integer(bit_kind) :: mask use bitmasks ASSERT (i_hole > 0 ) ASSERT (i_particle <= mo_num) @@ -19,31 +20,66 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok) ! hole k = shiftr(i_hole-1,bit_kind_shift)+1 j = i_hole-shiftl(k-1,bit_kind_shift)-1 + mask = ibset(0_bit_kind,j) ! check whether position j is occupied - if (ibits(key_in(k,ispin),j,1).eq.1) then + if (iand(key_in(k,ispin),mask) /= 0_bit_kind) then key_in(k,ispin) = ibclr(key_in(k,ispin),j) else i_ok= -1 + return end if ! particle k = shiftr(i_particle-1,bit_kind_shift)+1 j = i_particle-shiftl(k-1,bit_kind_shift)-1 - key_in(k,ispin) = ibset(key_in(k,ispin),j) + mask = ibset(0_bit_kind,j) + if (iand(key_in(k,ispin),mask) == 0_bit_kind) then + key_in(k,ispin) = ibset(key_in(k,ispin),j) + else + i_ok= -1 + return + end if - integer :: n_elec_tmp - n_elec_tmp = 0 - do i = 1, N_int - n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) - enddo - if(n_elec_tmp .ne. elec_num)then - !print*, n_elec_tmp,elec_num - !call debug_det(key_in,N_int) - i_ok = -1 - endif +! integer :: n_elec_tmp +! n_elec_tmp = 0 +! do i = 1, N_int +! n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) +! enddo +! if(n_elec_tmp .ne. elec_num)then +! print*, n_elec_tmp,elec_num +! call debug_det(key_in,N_int) +! stop -1 +! endif end +subroutine build_singly_excited_wavefunction(i_hole,i_particle,ispin,det_out,coef_out) + implicit none + BEGIN_DOC + ! Applies the single excitation operator : a^{dager}_(i_particle) a_(i_hole) of + ! spin = ispin to the current wave function (psi_det, psi_coef) + END_DOC + integer, intent(in) :: i_hole,i_particle,ispin + integer(bit_kind), intent(out) :: det_out(N_int,2,N_det) + double precision, intent(out) :: coef_out(N_det,N_states) + + integer :: k + integer :: i_ok + double precision :: phase + do k=1,N_det + coef_out(k,:) = psi_coef(k,:) + det_out(:,:,k) = psi_det(:,:,k) + call do_single_excitation(det_out(1,1,k),i_hole,i_particle,ispin,i_ok) + if (i_ok == 1) then + call get_phase(psi_det(1,1,k), det_out(1,1,k),phase,N_int) + coef_out(k,:) = phase * coef_out(k,:) + else + coef_out(k,:) = 0.d0 + det_out(:,:,k) = psi_det(:,:,k) + endif + enddo +end + logical function is_spin_flip_possible(key_in,i_flip,ispin) implicit none BEGIN_DOC diff --git a/src/zmq/utils.irp.f b/src/zmq/utils.irp.f index 2a0c1d2e..70f0830b 100644 --- a/src/zmq/utils.irp.f +++ b/src/zmq/utils.irp.f @@ -748,10 +748,11 @@ integer function add_task_to_taskserver(zmq_to_qp_run_socket,task) character*(*), intent(in) :: task integer :: rc, sze - character(len=:), allocatable :: message + character(len=:), allocatable :: message add_task_to_taskserver = 0 + allocate(character(len=len(task)+10+len(zmq_state)) :: message) message='add_task '//trim(zmq_state)//' '//trim(task) sze = len(message) rc = f77_zmq_send(zmq_to_qp_run_socket, message, sze, 0) From e6eb789ab30653c398746bb28649896d773177d7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Jun 2019 00:12:17 +0200 Subject: [PATCH 04/28] Dev lcpq (#49) * Add energy components * Fixed beta_rs * Update do_single_excitation --- ocaml/qp_tunnel.ml | 6 +++ src/determinants/create_excitations.irp.f | 60 ++++++++++++++++++----- src/dft_utils_one_e/ec_scan.irp.f | 2 +- src/tools/print_ci_vectors.irp.f | 1 + src/zmq/utils.irp.f | 3 +- 5 files changed, 58 insertions(+), 14 deletions(-) diff --git a/ocaml/qp_tunnel.ml b/ocaml/qp_tunnel.ml index c35a2bac..dee01980 100644 --- a/ocaml/qp_tunnel.ml +++ b/ocaml/qp_tunnel.ml @@ -363,6 +363,12 @@ let () = |> Zmq.Socket.send socket_in in + Printf.printf "On remote hosts, create ssh tunnel using: +ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s\n%!" + (port ) localhost (localport ) + (port+1) localhost (localport+1) + (port+9) localhost (localport+9) + (Unix.gethostname ()); Printf.printf "Ready\n%!"; while !run_status do diff --git a/src/determinants/create_excitations.irp.f b/src/determinants/create_excitations.irp.f index ddb9ae0f..cec87901 100644 --- a/src/determinants/create_excitations.irp.f +++ b/src/determinants/create_excitations.irp.f @@ -12,6 +12,7 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok) integer(bit_kind), intent(inout) :: key_in(N_int,2) integer, intent(out) :: i_ok integer :: k,j,i + integer(bit_kind) :: mask use bitmasks ASSERT (i_hole > 0 ) ASSERT (i_particle <= mo_num) @@ -19,31 +20,66 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok) ! hole k = shiftr(i_hole-1,bit_kind_shift)+1 j = i_hole-shiftl(k-1,bit_kind_shift)-1 + mask = ibset(0_bit_kind,j) ! check whether position j is occupied - if (ibits(key_in(k,ispin),j,1).eq.1) then + if (iand(key_in(k,ispin),mask) /= 0_bit_kind) then key_in(k,ispin) = ibclr(key_in(k,ispin),j) else i_ok= -1 + return end if ! particle k = shiftr(i_particle-1,bit_kind_shift)+1 j = i_particle-shiftl(k-1,bit_kind_shift)-1 - key_in(k,ispin) = ibset(key_in(k,ispin),j) + mask = ibset(0_bit_kind,j) + if (iand(key_in(k,ispin),mask) == 0_bit_kind) then + key_in(k,ispin) = ibset(key_in(k,ispin),j) + else + i_ok= -1 + return + end if - integer :: n_elec_tmp - n_elec_tmp = 0 - do i = 1, N_int - n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) - enddo - if(n_elec_tmp .ne. elec_num)then - !print*, n_elec_tmp,elec_num - !call debug_det(key_in,N_int) - i_ok = -1 - endif +! integer :: n_elec_tmp +! n_elec_tmp = 0 +! do i = 1, N_int +! n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) +! enddo +! if(n_elec_tmp .ne. elec_num)then +! print*, n_elec_tmp,elec_num +! call debug_det(key_in,N_int) +! stop -1 +! endif end +subroutine build_singly_excited_wavefunction(i_hole,i_particle,ispin,det_out,coef_out) + implicit none + BEGIN_DOC + ! Applies the single excitation operator : a^{dager}_(i_particle) a_(i_hole) of + ! spin = ispin to the current wave function (psi_det, psi_coef) + END_DOC + integer, intent(in) :: i_hole,i_particle,ispin + integer(bit_kind), intent(out) :: det_out(N_int,2,N_det) + double precision, intent(out) :: coef_out(N_det,N_states) + + integer :: k + integer :: i_ok + double precision :: phase + do k=1,N_det + coef_out(k,:) = psi_coef(k,:) + det_out(:,:,k) = psi_det(:,:,k) + call do_single_excitation(det_out(1,1,k),i_hole,i_particle,ispin,i_ok) + if (i_ok == 1) then + call get_phase(psi_det(1,1,k), det_out(1,1,k),phase,N_int) + coef_out(k,:) = phase * coef_out(k,:) + else + coef_out(k,:) = 0.d0 + det_out(:,:,k) = psi_det(:,:,k) + endif + enddo +end + logical function is_spin_flip_possible(key_in,i_flip,ispin) implicit none BEGIN_DOC diff --git a/src/dft_utils_one_e/ec_scan.irp.f b/src/dft_utils_one_e/ec_scan.irp.f index 7a4b587b..4807b89f 100644 --- a/src/dft_utils_one_e/ec_scan.irp.f +++ b/src/dft_utils_one_e/ec_scan.irp.f @@ -95,6 +95,6 @@ end double precision function beta_rs(rs) implicit none double precision, intent(in) ::rs - beta_rs(rs) = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) + beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) end diff --git a/src/tools/print_ci_vectors.irp.f b/src/tools/print_ci_vectors.irp.f index 9ba06d9a..97dfdc0b 100644 --- a/src/tools/print_ci_vectors.irp.f +++ b/src/tools/print_ci_vectors.irp.f @@ -24,6 +24,7 @@ subroutine routine implicit none integer :: i,k integer :: degree + call print_energy_components do i = 1, N_det print *, 'Determinant ', i call debug_det(psi_det(1,1,i),N_int) diff --git a/src/zmq/utils.irp.f b/src/zmq/utils.irp.f index 2a0c1d2e..70f0830b 100644 --- a/src/zmq/utils.irp.f +++ b/src/zmq/utils.irp.f @@ -748,10 +748,11 @@ integer function add_task_to_taskserver(zmq_to_qp_run_socket,task) character*(*), intent(in) :: task integer :: rc, sze - character(len=:), allocatable :: message + character(len=:), allocatable :: message add_task_to_taskserver = 0 + allocate(character(len=len(task)+10+len(zmq_state)) :: message) message='add_task '//trim(zmq_state)//' '//trim(task) sze = len(message) rc = f77_zmq_send(zmq_to_qp_run_socket, message, sze, 0) From 03003690edecc9e6396ce88c91a3ea12b233cdc6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 21 Jun 2019 12:08:58 +0200 Subject: [PATCH 05/28] Documentation --- src/determinants/occ_pattern.irp.f | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/determinants/occ_pattern.irp.f b/src/determinants/occ_pattern.irp.f index d5f458a0..5f37b289 100644 --- a/src/determinants/occ_pattern.irp.f +++ b/src/determinants/occ_pattern.irp.f @@ -53,7 +53,17 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) use bitmasks implicit none BEGIN_DOC - ! Generate all possible determinants for a give occ_pattern + ! Generate all possible determinants for a given occ_pattern + ! + ! Input : + ! o : occupation pattern : (doubly occupied, singly occupied) + ! sze : Number of produced determinants, computed by `occ_pattern_to_dets_size` + ! n_alpha : Number of $\alpha$ electrons + ! Nint : N_int + ! + ! Output: + ! d : determinants + ! END_DOC integer ,intent(in) :: Nint integer ,intent(in) :: n_alpha ! Number of alpha electrons From ecf8e0bb960cef1ae34266bf3fece7466ca5720e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 09:08:34 +0200 Subject: [PATCH 06/28] Biblio --- docs/source/research.bib | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/docs/source/research.bib b/docs/source/research.bib index 67a40766..03ffb39f 100644 --- a/docs/source/research.bib +++ b/docs/source/research.bib @@ -22,6 +22,20 @@ %%%% PUBLISHED PAPERS +@article{Ferte_2019, + doi = {10.1063/1.5082638}, + url = {https://doi.org/10.1063%2F1.5082638}, + year = 2019, + month = {feb}, + publisher = {{AIP} Publishing}, + volume = {150}, + number = {8}, + pages = {084103}, + author = {Anthony Fert{\'{e}} and Emmanuel Giner and Julien Toulouse}, + title = {Range-separated multideterminant density-functional theory with a short-range correlation functional of the on-top pair density}, + journal = {The Journal of Chemical Physics} +} + @article{Loos_2019, doi = {10.1021/acs.jpclett.9b01176}, url = {https://doi.org/10.1021%2Facs.jpclett.9b01176}, From 2f340f4841a986b47362f9e057fa04434a4eaeca Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 15:32:26 +0200 Subject: [PATCH 07/28] CAS-CI with no vvvv --- src/casscf/NEED | 3 +++ src/casscf/README.rst | 5 +++++ src/casscf/casscf.irp.f | 14 ++++++++++++++ src/casscf/class.irp.f | 12 ++++++++++++ src/cipsi/selection.irp.f | 10 ++++++++++ src/fci/class.irp.f | 2 ++ 6 files changed, 46 insertions(+) create mode 100644 src/casscf/NEED create mode 100644 src/casscf/README.rst create mode 100644 src/casscf/casscf.irp.f create mode 100644 src/casscf/class.irp.f diff --git a/src/casscf/NEED b/src/casscf/NEED new file mode 100644 index 00000000..d7aff476 --- /dev/null +++ b/src/casscf/NEED @@ -0,0 +1,3 @@ +cipsi +selectors_full +generators_cas 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/casscf.irp.f b/src/casscf/casscf.irp.f new file mode 100644 index 00000000..28f56069 --- /dev/null +++ b/src/casscf/casscf.irp.f @@ -0,0 +1,14 @@ +program casscf_new + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run + implicit none + call run_cipsi +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/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index df31bc39..062b44bf 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -683,6 +683,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 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 From 33f070ab0413abf462d232ca0fd075b51a31af8e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 15:37:09 +0200 Subject: [PATCH 08/28] CAS-CI works --- src/casscf/EZFIO.cfg | 13 +++++++++++++ src/casscf/save_energy.irp.f | 9 +++++++++ 2 files changed, 22 insertions(+) create mode 100644 src/casscf/EZFIO.cfg create mode 100644 src/casscf/save_energy.irp.f diff --git a/src/casscf/EZFIO.cfg b/src/casscf/EZFIO.cfg new file mode 100644 index 00000000..d5526673 --- /dev/null +++ b/src/casscf/EZFIO.cfg @@ -0,0 +1,13 @@ +[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) + + 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 From d29f82c0800de5baf37047b010b8f868cf630cf5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 16:42:16 +0200 Subject: [PATCH 09/28] CAS-CI and wdens merged --- src/casscf/bavard.irp.f | 6 + src/casscf/bielec_create.irp.f | 118 +++++++ src/casscf/casscf.irp.f | 4 +- src/casscf/densities.irp.f | 177 +++++++++++ src/casscf/det_manip.irp.f | 131 ++++++++ src/casscf/driver_wdens.irp.f | 154 +++++++++ src/casscf/natorb.irp.f | 548 +++++++++++++++++++++++++++++++++ src/casscf/tot_en.irp.f | 122 ++++++++ 8 files changed, 1259 insertions(+), 1 deletion(-) create mode 100644 src/casscf/bavard.irp.f create mode 100644 src/casscf/bielec_create.irp.f create mode 100644 src/casscf/densities.irp.f create mode 100644 src/casscf/det_manip.irp.f create mode 100644 src/casscf/driver_wdens.irp.f create mode 100644 src/casscf/natorb.irp.f create mode 100644 src/casscf/tot_en.irp.f diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f new file mode 100644 index 00000000..de71a346 --- /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_create.irp.f b/src/casscf/bielec_create.irp.f new file mode 100644 index 00000000..7e6d16c8 --- /dev/null +++ b/src/casscf/bielec_create.irp.f @@ -0,0 +1,118 @@ +! -*- F90 -*- + BEGIN_PROVIDER[real*8, bielec_PQxxtmp, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] +&BEGIN_PROVIDER[real*8, bielec_PxxQtmp, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] +&BEGIN_PROVIDER[integer, num_PQxx_written] +&BEGIN_PROVIDER[integer, num_PxxQ_written] +BEGIN_DOC +! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active +! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active +! indices are unshifted orbital numbers +END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + double precision, allocatable :: integrals_array1(:,:) + double precision, allocatable :: integrals_array2(:,:) + real*8 :: mo_two_e_integral + + allocate(integrals_array1(mo_num,mo_num)) + allocate(integrals_array2(mo_num,mo_num)) + + do i=1,n_core_orb+n_act_orb + do j=1,n_core_orb+n_act_orb + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i,j)=0.D0 + bielec_PxxQtmp(p,i,j,q)=0.D0 + end do + end do + end do + end do + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) +! (ij|pq) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) +! (ip|qj) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i,j)=integrals_array1(p,q) + bielec_PQxxtmp(p,q,j,i)=integrals_array1(p,q) + bielec_PxxQtmp(p,i,j,q)=integrals_array2(p,q) + bielec_PxxQtmp(p,j,i,q)=integrals_array2(q,p) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_orb +! (ij|pq) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) +! (ip|qj) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i,j3)=integrals_array1(p,q) + bielec_PQxxtmp(p,q,j3,i)=integrals_array1(p,q) + bielec_PxxQtmp(p,i,j3,q)=integrals_array2(p,q) + bielec_PxxQtmp(p,j3,i,q)=integrals_array2(q,p) + end do + end do + end do + end do + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb +! (ij|pq) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) +! (ip|qj) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i3,j3)=integrals_array1(p,q) + bielec_PQxxtmp(p,q,j3,i3)=integrals_array1(p,q) + bielec_PxxQtmp(p,i3,j3,q)=integrals_array2(p,q) + bielec_PxxQtmp(p,j3,i3,q)=integrals_array2(q,p) + end do + end do + end do + end do + write(6,*) ' provided integrals (PQ|xx) ' + write(6,*) ' provided integrals (Px|xQ) ' +!!$ write(6,*) ' 1 1 1 2 = ',bielec_PQxxtmp(2,2,2,3),bielec_PxxQtmp(2,2,2,3) +END_PROVIDER + +BEGIN_PROVIDER[real*8, bielecCItmp, (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, allocatable :: integrals_array1(:) + real*8 :: mo_two_e_integral + + allocate(integrals_array1(mo_num)) + + do i=1,n_act_orb + t=list_act(i) + do j=1,n_act_orb + u=list_act(j) + do k=1,n_act_orb + v=list_act(k) +! (tu|vp) + call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array1,mo_integrals_map) + do p=1,mo_num + bielecCItmp(i,k,j,p)=integrals_array1(p) + end do + end do + end do + end do + write(6,*) ' provided integrals (tu|xP) ' +END_PROVIDER + diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 28f56069..c08dd032 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -1,4 +1,4 @@ -program casscf_new +program casscf implicit none BEGIN_DOC ! TODO : Put the documentation of the program here @@ -11,4 +11,6 @@ end subroutine run implicit none call run_cipsi + call driver_wdens + end diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f new file mode 100644 index 00000000..77f5593e --- /dev/null +++ b/src/casscf/densities.irp.f @@ -0,0 +1,177 @@ +! -*- F90 -*- +use bitmasks ! you need to include the bitmasks_module.f90 features + + BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] +&BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] +BEGIN_DOC +! the first-order density matrix in the basis of the starting MOs +! the second-order density matrix in the basis of the starting MOs +! matrices 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> +! +END_DOC + implicit none + integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: ierr + integer(bit_kind), allocatable :: det_mu(:,:) + integer(bit_kind), allocatable :: det_mu_ex(:,:) + integer(bit_kind), allocatable :: det_mu_ex1(:,:) + integer(bit_kind), allocatable :: det_mu_ex11(:,:) + integer(bit_kind), allocatable :: det_mu_ex12(:,:) + integer(bit_kind), allocatable :: det_mu_ex2(:,:) + integer(bit_kind), allocatable :: det_mu_ex21(:,:) + integer(bit_kind), allocatable :: det_mu_ex22(:,:) + 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 + allocate(det_mu(N_int,2)) + allocate(det_mu_ex(N_int,2)) + allocate(det_mu_ex1(N_int,2)) + allocate(det_mu_ex11(N_int,2)) + allocate(det_mu_ex12(N_int,2)) + allocate(det_mu_ex2(N_int,2)) + allocate(det_mu_ex21(N_int,2)) + allocate(det_mu_ex22(N_int,2)) + + write(6,*) ' providing density matrices D0 and P0 ' + +! set all to zero + do t=1,n_act_orb + do u=1,n_act_orb + D0tu(u,t)=0.D0 + do v=1,n_act_orb + do x=1,n_act_orb + P0tuvx(x,v,u,t)=0.D0 + end do + end do + end do + end do + +! first loop: we apply E_tu, once for D_tu, once for -P_tvvu + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do t=1,n_act_orb + ipart=list_act(t) + do u=1,n_act_orb + ihole=list_act(u) +! apply E_tu + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) +! det_mu_ex1 is in the list + if (nu1.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 + D0tu(t,u)+=term +! and we fill P0_tvvu + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if +! det_mu_ex2 is in the list + if (nu2.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 + D0tu(t,u)+=term + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if + end do + end do + end do +! now we do the double excitation E_tu E_vx |0> + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do v=1,n_act_orb + ipart=list_act(v) + do x=1,n_act_orb + ihole=list_act(x) +! apply E_vx + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) +! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> + if (ierr1.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex1,det_mu_ex11,N_int) + call det_copy(det_mu_ex1,det_mu_ex12,N_int) + call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11 & + ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) + if (nu11.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate) & + *phase11*phase1 + end do + end if + if (nu12.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate) & + *phase12*phase1 + end do + end if + end do + end do + end if + +! we apply E_tu to the second resultant determinant + if (ierr2.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex2,det_mu_ex21,N_int) + call det_copy(det_mu_ex2,det_mu_ex22,N_int) + call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21 & + ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) + if (nu21.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate) & + *phase21*phase2 + end do + end if + if (nu22.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate) & + *phase22*phase2 + end do + end if + end do + end do + end if + + end do + end do + end do + +! we average by just dividing by the number of states + do x=1,n_act_orb + do v=1,n_act_orb + D0tu(v,x)*=1.0D0/dble(N_states) + do u=1,n_act_orb + do t=1,n_act_orb + P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) + end do + end do + end do + end do + +END_PROVIDER diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f new file mode 100644 index 00000000..c8e6c08a --- /dev/null +++ b/src/casscf/det_manip.irp.f @@ -0,0 +1,131 @@ +! -*- F90 -*- +use bitmasks ! you need to include the bitmasks_module.f90 features + + 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 + 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 +! if (found) then +! if (nu.eq.-1) then +! write(6,*) ' image not found in the list, thus nu = ',nu +! else +! write(6,*) ' found in the list as No ',nu,' phase = ',phase +! end if +! end if + 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_wdens.irp.f b/src/casscf/driver_wdens.irp.f new file mode 100644 index 00000000..263e8441 --- /dev/null +++ b/src/casscf/driver_wdens.irp.f @@ -0,0 +1,154 @@ + subroutine driver_wdens + implicit none + integer :: istate,p,q,r,s,indx,i,j + + + write(6,*) ' total energy = ',eone+etwo+ecore + write(6,*) ' generating natural orbitals ' + write(6,*) + write(6,*) + call trf_to_natorb + + write(6,*) ' all data available ! ' + write(6,*) ' writing out files ' + + open(unit=12,file='D0tu.dat',form='formatted',status='unknown') + do p=1,n_act_orb + do q=1,n_act_orb + if (abs(D0tu(p,q)).gt.1.D-12) then + write(12,'(2i8,E20.12)') p,q,D0tu(p,q) + end if + end do + end do + close(12) + +real*8 :: approx,np,nq,nr,ns +logical :: lpq,lrs,lps,lqr + open(unit=12,file='P0tuvx.dat',form='formatted',status='unknown') + do p=1,n_act_orb + np=D0tu(p,p) + do q=1,n_act_orb + lpq=p.eq.q + nq=D0tu(q,q) + do r=1,n_act_orb + lqr=q.eq.r + nr=D0tu(r,r) + do s=1,n_act_orb + lrs=r.eq.s + lps=p.eq.s + approx=0.D0 + if (lpq.and.lrs) then + if (lqr) then +! pppp + approx=0.5D0*np*(np-1.D0) + else +! pprr + approx=0.5D0*np*nr + end if + else + if (lps.and.lqr.and..not.lpq) then +! pqqp + approx=-0.25D0*np*nq + end if + end if + if (abs(P0tuvx(p,q,r,s)).gt.1.D-12) then + write(12,'(4i4,2E20.12)') p,q,r,s,P0tuvx(p,q,r,s),approx + end if + end do + end do + end do + end do + close(12) + + open(unit=12,form='formatted',status='unknown',file='onetrf.tmp') + indx=0 + do q=1,mo_num + do p=q,mo_num + if (abs(onetrf(p,q)).gt.1.D-12) then + write(12,'(2i6,E20.12)') p,q,onetrf(p,q) + indx+=1 + end if + end do + end do + write(6,*) ' wrote ',indx,' mono-electronic integrals' + close(12) + + + open(unit=12,form='formatted',status='unknown',file='bielec_PQxx.tmp') + indx=0 + do p=1,mo_num + do q=p,mo_num + do r=1,n_core_orb+n_act_orb + do s=r,n_core_orb+n_act_orb + if (abs(bielec_PQxxtmp(p,q,r,s)).gt.1.D-12) then + write(12,'(4i8,E20.12)') p,q,r,s,bielec_PQxxtmp(p,q,r,s) + indx+=1 + end if + end do + end do + end do + end do + write(6,*) ' wrote ',indx,' integrals (PQ|xx)' + close(12) + + open(unit=12,form='formatted',status='unknown',file='bielec_PxxQ.tmp') + indx=0 + do p=1,mo_num + do q=1,n_core_orb+n_act_orb + do r=q,n_core_orb+n_act_orb +integer ::s_start + if (q.eq.r) then + s_start=p + else + s_start=1 + end if + do s=s_start,mo_num + if (abs(bielec_PxxQtmp(p,q,r,s)).gt.1.D-12) then + write(12,'(4i8,E20.12)') p,q,r,s,bielec_PxxQtmp(p,q,r,s) + indx+=1 + end if + end do + end do + end do + end do + write(6,*) ' wrote ',indx,' integrals (Px|xQ)' + close(12) + + open(unit=12,form='formatted',status='unknown',file='bielecCI.tmp') + indx=0 + do p=1,n_act_orb + do q=p,n_act_orb + do r=1,n_act_orb + do s=1,mo_num + if (abs(bielecCItmp(p,q,r,s)).gt.1.D-12) then + write(12,'(4i8,E20.12)') p,q,r,s,bielecCItmp(p,q,r,s) + indx+=1 + end if + end do + end do + end do + end do + write(6,*) ' wrote ',indx,' integrals (tu|xP)' + close(12) + + write(6,*) + write(6,*) ' creating new orbitals ' + do i=1,mo_num + write(6,*) ' Orbital No ',i + write(6,'(5F14.6)') (NatOrbsFCI(j,i),j=1,mo_num) + write(6,*) + end do + + mo_label = "MCSCF" + mo_label = "Natural" + do i=1,mo_num + do j=1,ao_num + mo_coef(j,i)=NatOrbsFCI(j,i) + end do + end do + call save_mos + + write(6,*) ' ... done ' + + end + diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f new file mode 100644 index 00000000..a903260c --- /dev/null +++ b/src/casscf/natorb.irp.f @@ -0,0 +1,548 @@ +! -*- F90 -*- +! diagonalize D0tu +! save the diagonal somewhere, in inverse order +! 4-index-transform the 2-particle density matrix over active orbitals +! correct the bielectronic integrals +! correct the monoelectronic integrals +! put integrals on file, as well orbitals, and the density matrices +! + subroutine trf_to_natorb + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: eigval(n_act_orb),natorbsCI(n_act_orb,n_act_orb) + real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) + + call lapack_diag(eigval,natorbsCI,D0tu,n_act_orb,n_act_orb) + write(6,*) ' found occupation numbers as ' + do i=1,n_act_orb + write(6,*) i,eigval(i) + end do + + if (bavard) then +! + +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 + + do i=1,n_act_orb + do j=1,n_act_orb + D0tu(i,j)=0.D0 + end do +! fill occupation numbers in descending order + D0tu(i,i)=eigval(n_act_orb-i+1) + end do +! +! 4-index transformation of 2part matrices +! +! index per index +! first 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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(j,k,l,q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(j,k,l,p)=d(p) + end do + end do + end do + end do + write(6,*) ' transformed P0tuvx ' +! +! one-electron integrals +! + do i=1,mo_num + do j=1,mo_num + onetrf(i,j)=mo_one_e_integrals(i,j) + end do + end do +! 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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed onetrf ' +! +! Orbitals +! + do j=1,ao_num + do i=1,mo_num + NatOrbsFCI(j,i)=mo_coef(j,i) + end do + end do + + do j=1,ao_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + NatOrbsFCI(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed orbitals ' +! +! now the bielectronic integrals +! +!!$ write(6,*) ' before the transformation ' +!!$integer :: kk,ll,ii,jj +!!$real*8 :: h1,h2,h3 +!!$ do i=1,n_act_orb +!!$ ii=list_act(i) +!!$ do j=1,n_act_orb +!!$ jj=list_act(j) +!!$ do k=1,n_act_orb +!!$ kk=list_act(k) +!!$ do l=1,n_act_orb +!!$ ll=list_act(l) +!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) +!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) +!!$ h3=bielecCItmp(i,j,k,ll) +!!$ if ((h1.ne.h2).or.(h1.ne.h3)) then +!!$ write(6,9901) i,j,k,l,h1,h2,h3 +!!$9901 format(' aie ',4i4,3E20.12) +!!$9902 format('correct',4i4,3E20.12) +!!$ else +!!$ write(6,9902) i,j,k,l,h1,h2,h3 +!!$ end if +!!$ end do +!!$ end do +!!$ end do +!!$ end do + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(list_act(q),j,k,l)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(list_act(q),k,l,j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(list_act(p),j,k,l)=d1(p) + bielec_PxxQtmp(list_act(p),k,l,j)=d2(p) + end do + end do + end do + end do +! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(j,list_act(q),k,l)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(j,list_act(p),k,l)=d1(p) + bielec_PxxQtmp(j,k,l,list_act(p))=d2(p) + end do + end do + end do + end do +! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(j,k,n_core_orb+q,l)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(j,n_core_orb+q,l,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(j,k,n_core_orb+p,l)=d1(p) + bielec_PxxQtmp(j,n_core_orb+p,l,k)=d2(p) + end do + end do + end do + end do +! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(j,k,l,n_core_orb+q)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(j,l,n_core_orb+q,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(j,k,l,n_core_orb+p)=d1(p) + bielec_PxxQtmp(j,l,n_core_orb+p,k)=d2(p) + end do + end do + end do + end do + write(6,*) ' transformed PQxx and PxxQ ' +! +! and finally the bielecCI integrals +! + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(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,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(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,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + write(6,*) ' transformed tuvP ' +! +! that's all +! +!!$ +!!$! test coherence of the bielectronic integals +!!$! PQxx = PxxQ = tuvP for some of the indices +!!$ write(6,*) ' after the transformation ' +!!$ do i=1,n_act_orb +!!$ ii=list_act(i) +!!$ do j=1,n_act_orb +!!$ jj=list_act(j) +!!$ do k=1,n_act_orb +!!$ kk=list_act(k) +!!$ do l=1,n_act_orb +!!$ ll=list_act(l) +!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) +!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) +!!$ h3=bielecCItmp(i,j,k,ll) +!!$ if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then +!!$ write(6,9901) i,j,k,l,h1,h1-h2,h1-h3 +!!$ else +!!$ write(6,9902) i,j,k,l,h1,h2,h3 +!!$ end if +!!$ end do +!!$ end do +!!$ end do +!!$ end do + +! we recalculate total energies + write(6,*) + write(6,*) ' recalculating energies after the transformation ' + write(6,*) + write(6,*) + real*8 :: e_one_all + real*8 :: e_two_all + integer :: ii + integer :: jj + integer :: t3 + integer :: tt + integer :: u3 + integer :: uu + integer :: v + integer :: v3 + integer :: vv + integer :: x + integer :: x3 + integer :: xx + + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_orb + ii=list_core(i) + e_one_all+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(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)*onetrf(tt,uu) + do v=1,n_act_orb + v3=v+n_core_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) + end do + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(i) + ecore +=2.D0*onetrf(ii,ii) + ecore_bis+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(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_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + eone +=D0tu(t,u)*onetrf(tt,uu) + eone_bis+=D0tu(t,u)*onetrf(tt,uu) + do i=1,n_core_orb + ii=list_core(i) + eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(tt,ii,i,u3)) + eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & + -bielec_PxxQtmp(tt,i,i,uu)) + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb +real*8 :: h1,h2,h3 + h1=bielec_PQxxtmp(tt,uu,v3,x3) + h2=bielec_PxxQtmp(tt,u3,v3,xx) + h3=bielecCItmp(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 ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) 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 + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + + end subroutine trf_to_natorb + + BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] +&BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] +END_PROVIDER diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f new file mode 100644 index 00000000..8734006e --- /dev/null +++ b/src/casscf/tot_en.irp.f @@ -0,0 +1,122 @@ +! -*- F90 -*- + 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_orb + ii=list_core(i) + e_one_all+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(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_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) + end do + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(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_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(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_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_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_orb + ii=list_core(i) + eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(tt,ii,i,u3)) + eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & + -bielec_PxxQtmp(tt,i,i,uu)) + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb +real*8 :: h1,h2,h3 + h1=bielec_PQxxtmp(tt,uu,v3,x3) + h2=bielec_PxxQtmp(tt,u3,v3,xx) + h3=bielecCItmp(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 + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + write(6,*) ' nuclear (qp) = ',nuclear_repulsion + write(6,*) ' core energy (qp) = ',core_energy + write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) + write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) + write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) + write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) + +END_PROVIDER + + From 328ab2dadf856732af82aba1fd5386a3ab3ee909 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 17:03:27 +0200 Subject: [PATCH 10/28] All programs merged. Iterations not working --- src/casscf/bielec.irp.f | 104 ++++++ src/casscf/casscf.irp.f | 17 +- src/casscf/driver_optorb.irp.f | 32 ++ src/casscf/gradient.irp.f | 251 +++++++++++++ src/casscf/hessian.irp.f | 639 +++++++++++++++++++++++++++++++++ src/casscf/mcscf_fock.irp.f | 67 ++++ src/casscf/natorb_casscf.irp.f | 65 ++++ src/casscf/neworbs.irp.f | 222 ++++++++++++ src/casscf/one_ints.irp.f | 26 ++ 9 files changed, 1421 insertions(+), 2 deletions(-) create mode 100644 src/casscf/bielec.irp.f create mode 100644 src/casscf/driver_optorb.irp.f create mode 100644 src/casscf/gradient.irp.f create mode 100644 src/casscf/hessian.irp.f create mode 100644 src/casscf/mcscf_fock.irp.f create mode 100644 src/casscf/natorb_casscf.irp.f create mode 100644 src/casscf/neworbs.irp.f create mode 100644 src/casscf/one_ints.irp.f diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f new file mode 100644 index 00000000..a1ec155d --- /dev/null +++ b/src/casscf/bielec.irp.f @@ -0,0 +1,104 @@ +! -*- F90 -*- + BEGIN_PROVIDER[real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] +&BEGIN_PROVIDER[real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] +BEGIN_DOC +! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active +! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active +! indices are unshifted orbital numbers +! all integrals are read from files +END_DOC + implicit none + integer :: i,j,p,q,indx,kk + real*8 :: hhh + logical :: lread + + do i=1,n_core_orb+n_act_orb + do j=1,n_core_orb+n_act_orb + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j)=0.D0 + bielec_PxxQ(p,i,j,q)=0.D0 + end do + end do + end do + end do + + open(unit=12,form='formatted',status='old',file='bielec_PQxx.tmp') + lread=.true. + indx=0 + do while (lread) + read(12,*,iostat=kk) p,q,i,j,hhh + if (kk.ne.0) then + lread=.false. + else +! stored with p.le.q, i.le.j + bielec_PQxx(p,q,i,j)=hhh + bielec_PQxx(q,p,i,j)=hhh + bielec_PQxx(q,p,j,i)=hhh + bielec_PQxx(p,q,j,i)=hhh + indx+=1 + end if + end do + close(12) + write(6,*) ' read ',indx,' integrals PQxx into core ' + + open(unit=12,form='formatted',status='old',file='bielec_PxxQ.tmp') + lread=.true. + indx=0 + do while (lread) + read(12,*,iostat=kk) p,i,j,q,hhh + if (kk.ne.0) then + lread=.false. + else +! stored with (ip).le.(jq) + bielec_PxxQ(p,i,j,q)=hhh + bielec_PxxQ(q,j,i,p)=hhh + indx+=1 + end if + end do + write(6,*) ' read ',indx,' integrals PxxQ into core ' + close(12) + write(6,*) ' provided integrals (PQ|xx) and (Px|xQ) ' +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 +! inegrals read from file +END_DOC + implicit none + integer :: i,j,k,p,t,u,v,kk,indx + real*8 :: hhh + logical :: lread + + write(6,*) ' reading integrals bielecCI ' + + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do p=1,mo_num + bielecCI(i,k,j,p)=0.D0 + end do + end do + end do + end do + + open(unit=12,form='formatted',status='old',file='bielecCI.tmp') + lread=.true. + indx=0 + do while (lread) + read(12,*,iostat=kk) i,j,k,p,hhh + if (kk.ne.0) then + lread=.false. + else + bielecCI(i,j,k,p)=hhh + bielecCI(j,i,k,p)=hhh + indx+=1 + end if + end do + write(6,*) ' read ',indx,' integrals (aa|aP) into core ' + close(12) + write(6,*) ' provided integrals (tu|xP) ' +END_PROVIDER + diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index c08dd032..b55c4c3b 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -10,7 +10,20 @@ end subroutine run implicit none - call run_cipsi - call driver_wdens + double precision :: energy_old, energy + logical :: converged + converged = .False. + + energy = 0.d0 +! do while (.not.converged) + N_det = 1 + TOUCH N_det psi_det psi_coef + call run_cipsi + call driver_wdens + call driver_optorb + energy_old = energy + energy = eone+etwo+ecore + converged = dabs(energy - energy_old) < 1.d-10 +! enddo end diff --git a/src/casscf/driver_optorb.irp.f b/src/casscf/driver_optorb.irp.f new file mode 100644 index 00000000..591c90c9 --- /dev/null +++ b/src/casscf/driver_optorb.irp.f @@ -0,0 +1,32 @@ + subroutine driver_optorb + implicit none + integer :: i,j + + write(6,*) +! write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) + write(6,*) ' energy improvement = ',energy_improvement +! write(6,*) ' new energy = ',psi_energy_with_nucl_rep(1)+energy_improvement + write(6,*) + + write(6,*) + write(6,*) ' creating new orbitals ' + do i=1,mo_num + write(6,*) ' Orbital No ',i + write(6,'(5F14.6)') (NewOrbs(j,i),j=1,mo_num) + write(6,*) + end do + + mo_label = "Natural" + do i=1,mo_num + do j=1,ao_num + mo_coef(j,i)=NewOrbs(j,i) + end do + end do + call save_mos + call map_deinit(mo_integrals_map) + FREE mo_integrals_map mo_coef mo_two_e_integrals_in_map + + write(6,*) + write(6,*) ' ... all done ' + + end diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f new file mode 100644 index 00000000..d35d96ed --- /dev/null +++ b/src/casscf/gradient.irp.f @@ -0,0 +1,251 @@ +! -*- F90 -*- + +use bitmasks ! you need to include the bitmasks_module.f90 features + +BEGIN_PROVIDER [ integer, nMonoEx ] +BEGIN_DOC +! +END_DOC + implicit none + nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb + write(6,*) ' nMonoEx = ',nMonoEx +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_orb + i=list_core(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_orb + i=list_core(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) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + + +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 +! write(6,*) +! write(6,*) ' mu = ',mu +! call print_det(det_mu,N_int) +! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin +! call print_det(det_mu_ex,N_int) + 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 +! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res + 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_orb + do t=1,n_act_orb + indx+=1 + gradvec2(indx)=gradvec_it(i,t) + end do + end do + + do i=1,n_core_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) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) + +END_PROVIDER + + real*8 function gradvec_it(i,t) +BEGIN_DOC +! the orbital gradient core -> 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(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_orb + do y=1,n_act_orb + y3=y+n_core_orb + gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx(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 -> virtual +END_DOC + implicit none + integer :: i,a,ii,aa + + ii=list_core(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(x,y,v,aa) + end do + end do + end do + gradvec_ta*=2.D0 + + end function gradvec_ta + diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f new file mode 100644 index 00000000..4603d11e --- /dev/null +++ b/src/casscf/hessian.irp.f @@ -0,0 +1,639 @@ +! -*- F90 -*- + +use bitmasks ! you need to include the bitmasks_module.f90 features + +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 + + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + + 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) +! write(6,*) ' Hessian ',ihole,'->',ipart & +! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',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 + + real*8 :: hessmat_itju + real*8 :: hessmat_itja + real*8 :: hessmat_itua + real*8 :: hessmat_iajb + real*8 :: hessmat_iatb + real*8 :: hessmat_taub + + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + + indx=1 + do i=1,n_core_orb + do t=1,n_act_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + ustart=t + else + ustart=1 + end if + do u=ustart,n_act_orb + hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) + hessmat2(jndx,indx)=hessmat2(indx,jndx) +! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) + jndx+=1 + end do + end do + do j=1,n_core_orb + do a=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do u=1,n_act_orb + do a=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do t=1,n_act_orb + do b=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + 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(indx,jndx)=hessmat_taub(t,a,u,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + +END_PROVIDER + + real*8 function hessmat_itju(i,t,j,u) +BEGIN_DOC +! the orbital hessian for core->act,core->act +! 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 + +! write(6,*) ' hessmat_itju ',i,t,j,u + ii=list_core(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(tt,i,i,tt)-bielec_pqxx(tt,tt,i,i)) + term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq(tt,i,i,tt) & + -bielec_pqxx(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(vv,xx,i,i) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(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(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & + -bielec_PQxx(tt,uu,i,j)) + term-=occnum(tt)*Fipq(uu,tt) + term-=(occnum(tt)+occnum(uu)) & + *(3.D0*bielec_PxxQ(tt,i,i,uu)-bielec_PQxx(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(vv,xx,i,i) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(u,v,y,xx) + end do + end do + end do +!!! write(6,*) ' direct diff ',i,t,j,u,term,term2 +!!! term=term2 + end if + else +! it/ju + jj=list_core(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(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & + -bielec_PQxx(tt,uu,i,j)) + term-=(occnum(tt)+occnum(uu))* & + (4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & + -bielec_PQxx(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(vv,xx,i,j) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq(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->act,core->virt +END_DOC + implicit none + integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y + real*8 :: term + +! write(6,*) ' hessmat_itja ',i,t,j,a +! it/ja + ii=list_core(i) + tt=list_act(t) + jj=list_core(j) + aa=list_virt(a) + term=2.D0*(4.D0*bielec_pxxq(aa,j,i,tt) & + -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt)) + term-=occnum(tt)*(4.D0*bielec_pxxq(aa,j,i,tt) & + -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(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(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->act,act->virt +END_DOC + implicit none + integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 + real*8 :: term + +! write(6,*) ' hessmat_itua ',i,t,u,a + ii=list_core(i) + tt=list_act(t) + t3=t+n_core_orb + uu=list_act(u) + u3=u+n_core_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(aa,ii,t3,u3)-4.D0*bielec_pqxx(aa,uu,t3,i) & + +bielec_pxxq(aa,t3,u3,ii)) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb +integer :: x3 + xx=list_act(x) + x3=x+n_core_orb + term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,ii,v3,x3) & + +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & + *bielec_pqxx(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->virt,core->virt +END_DOC + implicit none + integer :: i,a,j,b,ii,aa,jj,bb + real*8 :: term +! write(6,*) ' hessmat_iajb ',i,a,j,b + + ii=list_core(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(aa,i,i,aa)-bielec_pqxx(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(aa,i,i,bb)-bielec_pqxx(aa,bb,i,i)) + end if + else +! ia/jb + jj=list_core(j) + bb=list_virt(b) + term=2.D0*(4.D0*bielec_pxxq(aa,i,j,bb)-bielec_pqxx(aa,bb,i,j) & + -bielec_pxxq(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->virt,act->virt +END_DOC + implicit none + integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 + real*8 :: term + +! write(6,*) ' hessmat_iatb ',i,a,t,b + ii=list_core(i) + aa=list_virt(a) + tt=list_act(t) + bb=list_virt(b) + t3=t+n_core_orb + term=occnum(tt)*(4.D0*bielec_pxxq(aa,i,t3,bb)-bielec_pxxq(aa,t3,i,bb) & + -bielec_pqxx(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(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 + + tt=list_act(t) + aa=list_virt(a) + if (t.eq.u) then + if (a.eq.b) then +! ta/ta + t1=occnum(tt)*Fipq(aa,aa) + t2=0.D0 + t3=0.D0 + t1-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,aa,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq(aa,x3,v3,aa)) + do y=1,n_act_orb + t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx) + end do + end do + end do + term=t1+t2+t3 +! write(6,*) ' Hess taub ',t,a,t1,t2,t3 + else + bb=list_virt(b) +! ta/tb b/=a + term=occnum(tt)*Fipq(aa,bb) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & + *bielec_pxxq(aa,x3,v3,bb)) + end do + end do + end if + else +! ta/ub t/=u + uu=list_act(u) + bb=list_virt(b) + term=0.D0 + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & + *bielec_pxxq(aa,x3,v3,bb)) + end do + end do + 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 x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,uu) + term-=P0tuvx_no(u,v,x,y)*bielecCI(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 + real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + hessdiag(indx)=hessmat_itju(i,t,i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_iajb(i,a,i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_taub(t,a,t,a) + end do + end do + +END_PROVIDER diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f new file mode 100644 index 00000000..301b1418 --- /dev/null +++ b/src/casscf/mcscf_fock.irp.f @@ -0,0 +1,67 @@ +! -*- F90 -*- + BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] +&BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] +BEGIN_DOC +! the inactive and the active Fock matrices, 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 + double precision, allocatable :: integrals_array1(:,:) + double precision, allocatable :: integrals_array2(:,:) + integer :: p,q,k,kk,t,tt,u,uu + allocate(integrals_array1(mo_num,mo_num)) + allocate(integrals_array2(mo_num,mo_num)) + + do p=1,mo_num + do q=1,mo_num + Fipq(p,q)=one_ints(p,q) + Fapq(p,q)=0.D0 + end do + end do + +! the inactive Fock matrix + do k=1,n_core_orb + kk=list_core(k) + do p=1,mo_num + do q=1,mo_num + Fipq(p,q)+=2.D0*bielec_pqxx(p,q,k,k) -bielec_pxxq(p,k,k,q) + end do + end do + end do + +! the active Fock matrix, D0tu is diagonal + do t=1,n_act_orb + tt=list_act(t) + do p=1,mo_num + do q=1,mo_num + Fapq(p,q)+=occnum(tt) & + *(bielec_pqxx(p,q,tt,tt)-0.5D0*bielec_pxxq(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_casscf.irp.f b/src/casscf/natorb_casscf.irp.f new file mode 100644 index 00000000..0a818a34 --- /dev/null +++ b/src/casscf/natorb_casscf.irp.f @@ -0,0 +1,65 @@ +! -*- F90 -*- +BEGIN_PROVIDER [real*8, occnum, (mo_num)] + implicit none + integer :: i,kk,j + logical :: lread + real*8 :: rdum + do i=1,mo_num + occnum(i)=0.D0 + end do + do i=1,n_core_orb + occnum(list_core(i))=2.D0 + end do + + open(unit=12,file='D0tu.dat',form='formatted',status='old') + lread=.true. + do while (lread) + read(12,*,iostat=kk) i,j,rdum + if (kk.ne.0) then + lread=.false. + else + if (i.eq.j) then + occnum(list_act(i))=rdum + else + write(6,*) ' WARNING - no natural orbitals !' + write(6,*) i,j,rdum + end if + end if + end do + close(12) + write(6,*) ' read occupation numbers ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do + +END_PROVIDER + +BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + integer :: i,j,k,l,kk + real*8 :: rdum + logical :: lread + + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + P0tuvx_no(l,k,j,i)=0.D0 + end do + end do + end do + end do + + open(unit=12,file='P0tuvx.dat',form='formatted',status='old') + lread=.true. + do while (lread) + read(12,*,iostat=kk) i,j,k,l,rdum + if (kk.ne.0) then + lread=.false. + else + P0tuvx_no(i,j,k,l)=rdum + end if + end do + close(12) + write(6,*) ' read the 2-particle density matrix ' +END_PROVIDER diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f new file mode 100644 index 00000000..6d63a86e --- /dev/null +++ b/src/casscf/neworbs.irp.f @@ -0,0 +1,222 @@ +! -*- F90 -*- +BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] + implicit none + 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+1 + 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)] + END_PROVIDER + + BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)] +&BEGIN_PROVIDER [real*8, energy_improvement] + implicit none + integer :: ierr,matz,i + real*8 :: c0 + + call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) + 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) + energy_improvement = SXeigenval(1) + +integer :: best_vector +real*8 :: best_overlap + best_overlap=0.D0 + 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 + + write(6,*) ' SXdiag : eigenvalue for best overlap with ' + write(6,*) ' previous orbitals = ',SXeigenval(best_vector) + energy_improvement = SXeigenval(best_vector) + + c0=SXeigenvec(1,best_vector) + write(6,*) ' weight of the 1st element ',c0 + do i=1,nMonoEx+1 + SXvector(i)=SXeigenvec(i,best_vector)/c0 +! write(6,*) ' component No ',i,' : ',SXvector(i) + end do + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ] + implicit none + integer :: i,j,ialph + +! form the exponential of the Orbital rotations + call get_orbrotmat +! form the new orbitals + do i=1,ao_num + do j=1,mo_num + NewOrbs(i,j)=0.D0 + end do + end do + + do ialph=1,ao_num + do i=1,mo_num + wrkline(i)=mo_coef(ialph,i) + end do + do i=1,mo_num + do j=1,mo_num + NewOrbs(ialph,i)+=Umat(i,j)*wrkline(j) + end do + end do + end do + +END_PROVIDER + + BEGIN_PROVIDER [real*8, Tpotmat, (mo_num,mo_num) ] +&BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] +&BEGIN_PROVIDER [real*8, wrkline, (mo_num) ] +&BEGIN_PROVIDER [real*8, Tmat, (mo_num,mo_num) ] +END_PROVIDER + + subroutine get_orbrotmat + implicit none + integer :: i,j,indx,k,iter,t,a,ii,tt,aa + real*8 :: sum + logical :: converged + + +! the orbital rotation matrix T + do i=1,mo_num + do j=1,mo_num + Tmat(i,j)=0.D0 + Umat(i,j)=0.D0 + Tpotmat(i,j)=0.D0 + end do + Tpotmat(i,i)=1.D0 + end do + + indx=1 + do i=1,n_core_orb + ii=list_core(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_orb + ii=list_core(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 + + write(6,*) ' the T matrix ' + do indx=1,nMonoEx + i=excit(1,indx) + j=excit(2,indx) +! if (abs(Tmat(i,j)).gt.1.D0) then +! write(6,*) ' setting matrix element ',i,j,' of ',Tmat(i,j),' to ' & +! , sign(1.D0,Tmat(i,j)) +! Tmat(i,j)=sign(1.D0,Tmat(i,j)) +! Tmat(j,i)=-Tmat(i,j) +! end if + if (abs(Tmat(i,j)).gt.1.D-9) write(6,9901) i,j,excit_class(indx),Tmat(i,j) + 9901 format(' ',i4,' -> ',i4,' (',A3,') : ',E14.6) + end do + + write(6,*) + write(6,*) ' forming the matrix exponential ' + write(6,*) +! form the exponential + iter=0 + converged=.false. + do while (.not.converged) + iter+=1 +! add the next term + do i=1,mo_num + do j=1,mo_num + Umat(i,j)+=Tpotmat(i,j) + end do + end do +! next power of T, we multiply Tpotmat with Tmat/iter + do i=1,mo_num + do j=1,mo_num + wrkline(j)=Tpotmat(i,j)/dble(iter) + Tpotmat(i,j)=0.D0 + end do + do j=1,mo_num + do k=1,mo_num + Tpotmat(i,j)+=wrkline(k)*Tmat(k,j) + end do + end do + end do +! Convergence test + sum=0.D0 + do i=1,mo_num + do j=1,mo_num + sum+=abs(Tpotmat(i,j)) + end do + end do + write(6,*) ' Iteration No ',iter,' Sum = ',sum + if (sum.lt.1.D-6) then + converged=.true. + end if + if (iter.ge.NItExpMax) then + stop ' no convergence ' + end if + end do + write(6,*) + write(6,*) ' Converged ! ' + write(6,*) + + end subroutine get_orbrotmat + +BEGIN_PROVIDER [integer, NItExpMax] + NItExpMax=100 +END_PROVIDER + + diff --git a/src/casscf/one_ints.irp.f b/src/casscf/one_ints.irp.f new file mode 100644 index 00000000..a802f644 --- /dev/null +++ b/src/casscf/one_ints.irp.f @@ -0,0 +1,26 @@ +! -*- F90 -*- +BEGIN_PROVIDER [real*8, one_ints, (mo_num,mo_num)] + implicit none + integer :: i,j,kk + logical :: lread + real*8 :: rdum + do i=1,mo_num + do j=1,mo_num + one_ints(i,j)=0.D0 + end do + end do + open(unit=12,file='onetrf.tmp',status='old',form='formatted') + lread=.true. + do while (lread) + read(12,*,iostat=kk) i,j,rdum + if (kk.ne.0) then + lread=.false. + else + one_ints(i,j)=rdum + one_ints(j,i)=rdum + end if + end do + close(12) + write(6,*) ' read MCSCF natural one-electron integrals ' +END_PROVIDER + From 26be853c18189096dea671da1766724540f0a859 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 25 Jun 2019 16:46:14 +0200 Subject: [PATCH 11/28] Cleaning --- src/casscf/bielec.irp.f | 237 ++++--- src/casscf/bielec_create.irp.f | 118 ---- src/casscf/bielec_natorb.irp.f | 273 ++++++++ src/casscf/densities.irp.f | 377 +++++----- src/casscf/det_manip.irp.f | 249 ++++--- src/casscf/driver_wdens.irp.f | 104 +-- src/casscf/gradient.irp.f | 460 ++++++------ src/casscf/hessian.irp.f | 1204 ++++++++++++++++---------------- src/casscf/mcscf_fock.irp.f | 141 ++-- src/casscf/natorb.irp.f | 915 ++++++++++-------------- src/casscf/natorb_casscf.irp.f | 65 -- src/casscf/tot_en.irp.f | 203 +++--- 12 files changed, 2126 insertions(+), 2220 deletions(-) delete mode 100644 src/casscf/bielec_create.irp.f create mode 100644 src/casscf/bielec_natorb.irp.f delete mode 100644 src/casscf/natorb_casscf.irp.f diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index a1ec155d..9bb953f8 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -1,104 +1,151 @@ -! -*- F90 -*- - BEGIN_PROVIDER[real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] -&BEGIN_PROVIDER[real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] -BEGIN_DOC -! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active -! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active -! indices are unshifted orbital numbers -! all integrals are read from files -END_DOC - implicit none - integer :: i,j,p,q,indx,kk - real*8 :: hhh - logical :: lread + BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_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 + double precision, allocatable :: integrals_array(:,:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num,mo_num)) + + bielec_PQxx = 0.d0 + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j)=integrals_array(p,q) + bielec_PQxx(p,q,j,i)=integrals_array(p,q) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j3)=integrals_array(p,q) + bielec_PQxx(p,q,j3,i)=integrals_array(p,q) + end do + end do + end do + end do - do i=1,n_core_orb+n_act_orb - do j=1,n_core_orb+n_act_orb - do p=1,mo_num - do q=1,mo_num - bielec_PQxx(p,q,i,j)=0.D0 - bielec_PxxQ(p,i,j,q)=0.D0 - end do - end do - end do - end do - open(unit=12,form='formatted',status='old',file='bielec_PQxx.tmp') - lread=.true. - indx=0 - do while (lread) - read(12,*,iostat=kk) p,q,i,j,hhh - if (kk.ne.0) then - lread=.false. - else -! stored with p.le.q, i.le.j - bielec_PQxx(p,q,i,j)=hhh - bielec_PQxx(q,p,i,j)=hhh - bielec_PQxx(q,p,j,i)=hhh - bielec_PQxx(p,q,j,i)=hhh - indx+=1 - end if - end do - close(12) - write(6,*) ' read ',indx,' integrals PQxx into core ' - - open(unit=12,form='formatted',status='old',file='bielec_PxxQ.tmp') - lread=.true. - indx=0 - do while (lread) - read(12,*,iostat=kk) p,i,j,q,hhh - if (kk.ne.0) then - lread=.false. - else -! stored with (ip).le.(jq) - bielec_PxxQ(p,i,j,q)=hhh - bielec_PxxQ(q,j,i,p)=hhh - indx+=1 - end if - end do - write(6,*) ' read ',indx,' integrals PxxQ into core ' - close(12) - write(6,*) ' provided integrals (PQ|xx) and (Px|xQ) ' + ! (ij|pq) + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i3,j3)=integrals_array(p,q) + bielec_PQxx(p,q,j3,i3)=integrals_array(p,q) + end do + end do + end do + end do + + write(6,*) ' provided integrals (PQ|xx) ' 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 -! inegrals read from file -END_DOC - implicit none - integer :: i,j,k,p,t,u,v,kk,indx - real*8 :: hhh - logical :: lread - write(6,*) ' reading integrals bielecCI ' - do i=1,n_act_orb - do j=1,n_act_orb - do k=1,n_act_orb - do p=1,mo_num - bielecCI(i,k,j,p)=0.D0 - end do - end do - end do - end do +BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_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 + + allocate(integrals_array(mo_num,mo_num)) + + bielec_PxxQ = 0.d0 + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + 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_orb + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + 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 - open(unit=12,form='formatted',status='old',file='bielecCI.tmp') - lread=.true. - indx=0 - do while (lread) - read(12,*,iostat=kk) i,j,k,p,hhh - if (kk.ne.0) then - lread=.false. - else - bielecCI(i,j,k,p)=hhh - bielecCI(j,i,k,p)=hhh - indx+=1 - end if - end do - write(6,*) ' read ',indx,' integrals (aa|aP) into core ' - close(12) - write(6,*) ' provided integrals (tu|xP) ' + + ! (ip|qj) + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + 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 + write(6,*) ' provided integrals (Px|xQ) ' +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, allocatable :: integrals_array(:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num)) + + do i=1,n_act_orb + t=list_act(i) + do j=1,n_act_orb + u=list_act(j) + do k=1,n_act_orb + v=list_act(k) + ! (tu|vp) + call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + bielecCI(i,k,j,p)=integrals_array(p) + end do + end do + end do + end do + write(6,*) ' provided integrals (tu|xP) ' END_PROVIDER diff --git a/src/casscf/bielec_create.irp.f b/src/casscf/bielec_create.irp.f deleted file mode 100644 index 7e6d16c8..00000000 --- a/src/casscf/bielec_create.irp.f +++ /dev/null @@ -1,118 +0,0 @@ -! -*- F90 -*- - BEGIN_PROVIDER[real*8, bielec_PQxxtmp, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] -&BEGIN_PROVIDER[real*8, bielec_PxxQtmp, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] -&BEGIN_PROVIDER[integer, num_PQxx_written] -&BEGIN_PROVIDER[integer, num_PxxQ_written] -BEGIN_DOC -! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active -! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active -! indices are unshifted orbital numbers -END_DOC - implicit none - integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 - double precision, allocatable :: integrals_array1(:,:) - double precision, allocatable :: integrals_array2(:,:) - real*8 :: mo_two_e_integral - - allocate(integrals_array1(mo_num,mo_num)) - allocate(integrals_array2(mo_num,mo_num)) - - do i=1,n_core_orb+n_act_orb - do j=1,n_core_orb+n_act_orb - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i,j)=0.D0 - bielec_PxxQtmp(p,i,j,q)=0.D0 - end do - end do - end do - end do - - do i=1,n_core_orb - ii=list_core(i) - do j=i,n_core_orb - jj=list_core(j) -! (ij|pq) - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) -! (ip|qj) - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i,j)=integrals_array1(p,q) - bielec_PQxxtmp(p,q,j,i)=integrals_array1(p,q) - bielec_PxxQtmp(p,i,j,q)=integrals_array2(p,q) - bielec_PxxQtmp(p,j,i,q)=integrals_array2(q,p) - end do - end do - end do - do j=1,n_act_orb - jj=list_act(j) - j3=j+n_core_orb -! (ij|pq) - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) -! (ip|qj) - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i,j3)=integrals_array1(p,q) - bielec_PQxxtmp(p,q,j3,i)=integrals_array1(p,q) - bielec_PxxQtmp(p,i,j3,q)=integrals_array2(p,q) - bielec_PxxQtmp(p,j3,i,q)=integrals_array2(q,p) - end do - end do - end do - end do - do i=1,n_act_orb - ii=list_act(i) - i3=i+n_core_orb - do j=i,n_act_orb - jj=list_act(j) - j3=j+n_core_orb -! (ij|pq) - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) -! (ip|qj) - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i3,j3)=integrals_array1(p,q) - bielec_PQxxtmp(p,q,j3,i3)=integrals_array1(p,q) - bielec_PxxQtmp(p,i3,j3,q)=integrals_array2(p,q) - bielec_PxxQtmp(p,j3,i3,q)=integrals_array2(q,p) - end do - end do - end do - end do - write(6,*) ' provided integrals (PQ|xx) ' - write(6,*) ' provided integrals (Px|xQ) ' -!!$ write(6,*) ' 1 1 1 2 = ',bielec_PQxxtmp(2,2,2,3),bielec_PxxQtmp(2,2,2,3) -END_PROVIDER - -BEGIN_PROVIDER[real*8, bielecCItmp, (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, allocatable :: integrals_array1(:) - real*8 :: mo_two_e_integral - - allocate(integrals_array1(mo_num)) - - do i=1,n_act_orb - t=list_act(i) - do j=1,n_act_orb - u=list_act(j) - do k=1,n_act_orb - v=list_act(k) -! (tu|vp) - call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array1,mo_integrals_map) - do p=1,mo_num - bielecCItmp(i,k,j,p)=integrals_array1(p) - end do - end do - end do - end do - write(6,*) ' provided integrals (tu|xP) ' -END_PROVIDER - diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f new file mode 100644 index 00000000..2f1e43eb --- /dev/null +++ b/src/casscf/bielec_natorb.irp.f @@ -0,0 +1,273 @@ + BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_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,pp + real*8 :: d(n_act_orb) + + bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:) + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(list_act(q),j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(list_act(p),j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,list_act(q),k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,list_act(p),k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,k,n_core_orb+q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,k,n_core_orb+p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,k,l,n_core_orb+q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,k,l,n_core_orb+p)=d(p) + end do + end do + end do + end do + write(6,*) ' transformed PQxx' + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] + BEGIN_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,pp + real*8 :: d(n_act_orb) + + bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:) + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(list_act(q),k,l,j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(list_act(p),k,l,j)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,n_core_orb+q,l,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,n_core_orb+p,l,k)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,l,n_core_orb+q,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,l,n_core_orb+p,k)=d(p) + end do + end do + end do + end do + write(6,*) ' transformed PxxQ ' + +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,pp + real*8 :: d(n_act_orb) + + bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:) + + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(p,j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_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,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + write(6,*) ' transformed tuvP ' + +END_PROVIDER + diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 77f5593e..6e8065e2 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -1,177 +1,216 @@ -! -*- F90 -*- -use bitmasks ! you need to include the bitmasks_module.f90 features +use bitmasks - BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] -&BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] -BEGIN_DOC -! the first-order density matrix in the basis of the starting MOs -! the second-order density matrix in the basis of the starting MOs -! matrices 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> -! -END_DOC - implicit none - integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart - integer :: ierr - integer(bit_kind), allocatable :: det_mu(:,:) - integer(bit_kind), allocatable :: det_mu_ex(:,:) - integer(bit_kind), allocatable :: det_mu_ex1(:,:) - integer(bit_kind), allocatable :: det_mu_ex11(:,:) - integer(bit_kind), allocatable :: det_mu_ex12(:,:) - integer(bit_kind), allocatable :: det_mu_ex2(:,:) - integer(bit_kind), allocatable :: det_mu_ex21(:,:) - integer(bit_kind), allocatable :: det_mu_ex22(:,:) - 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 - allocate(det_mu(N_int,2)) - allocate(det_mu_ex(N_int,2)) - allocate(det_mu_ex1(N_int,2)) - allocate(det_mu_ex11(N_int,2)) - allocate(det_mu_ex12(N_int,2)) - allocate(det_mu_ex2(N_int,2)) - allocate(det_mu_ex21(N_int,2)) - allocate(det_mu_ex22(N_int,2)) - - write(6,*) ' providing density matrices D0 and P0 ' - -! set all to zero - do t=1,n_act_orb - do u=1,n_act_orb - D0tu(u,t)=0.D0 - do v=1,n_act_orb - do x=1,n_act_orb - P0tuvx(x,v,u,t)=0.D0 - end do - end do - end do - end do - -! first loop: we apply E_tu, once for D_tu, once for -P_tvvu - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do t=1,n_act_orb - ipart=list_act(t) - do u=1,n_act_orb - ihole=list_act(u) -! apply E_tu - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & +BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] + BEGIN_DOC + ! the first-order density matrix in the basis of the starting MOs + ! matrices 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 + ! + END_DOC + implicit none + integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: ierr + integer(bit_kind) :: det_mu(N_int,2) + integer(bit_kind) :: det_mu_ex(N_int,2) + integer(bit_kind) :: det_mu_ex1(N_int,2) + integer(bit_kind) :: det_mu_ex2(N_int,2) + real*8 :: phase1,phase2,term + integer :: nu1,nu2 + integer :: ierr1,ierr2 + real*8 :: cI_mu(N_states) + + write(6,*) ' providing density matrices D0 and P0 ' + + D0tu = 0.d0 + + ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do t=1,n_act_orb + ipart=list_act(t) + do u=1,n_act_orb + ihole=list_act(u) + ! apply E_tu + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) -! det_mu_ex1 is in the list - if (nu1.ne.-1) then + ! det_mu_ex1 is in the list + if (nu1.ne.-1) then do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 - D0tu(t,u)+=term -! and we fill P0_tvvu - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do + term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 + D0tu(t,u)+=term end do - end if -! det_mu_ex2 is in the list - if (nu2.ne.-1) then + end if + ! det_mu_ex2 is in the list + if (nu2.ne.-1) then do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 - D0tu(t,u)+=term - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do + term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 + D0tu(t,u)+=term end do - end if - end do - end do + end if end do -! now we do the double excitation E_tu E_vx |0> - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do v=1,n_act_orb - ipart=list_act(v) - do x=1,n_act_orb - ihole=list_act(x) -! apply E_vx - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) -! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> - if (ierr1.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex1,det_mu_ex11,N_int) - call det_copy(det_mu_ex1,det_mu_ex12,N_int) - call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11 & - ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) - if (nu11.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate) & - *phase11*phase1 - end do - end if - if (nu12.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate) & - *phase12*phase1 - end do - end if - end do - end do - end if - -! we apply E_tu to the second resultant determinant - if (ierr2.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex2,det_mu_ex21,N_int) - call det_copy(det_mu_ex2,det_mu_ex22,N_int) - call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21 & - ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) - if (nu21.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate) & - *phase21*phase2 - end do - end if - if (nu22.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate) & - *phase22*phase2 - end do - end if - end do - end do - end if - - end do - end do - end do - -! we average by just dividing by the number of states - do x=1,n_act_orb - do v=1,n_act_orb - D0tu(v,x)*=1.0D0/dble(N_states) - do u=1,n_act_orb - do t=1,n_act_orb - P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) - end do - end do - end do - end do - + end do + end do + + ! we average by just dividing by the number of states + do x=1,n_act_orb + do v=1,n_act_orb + D0tu(v,x)*=1.0D0/dble(N_states) + end do + end do + +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 + ! matrices 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> + ! + END_DOC + implicit none + integer :: t,u,v,x,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 + + write(6,*) ' providing density matrices D0 and P0 ' + + P0tuvx = 0.d0 + + ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do t=1,n_act_orb + ipart=list_act(t) + do u=1,n_act_orb + ihole=list_act(u) + ! apply E_tu + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) + ! det_mu_ex1 is in the list + if (nu1.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 + ! and we fill P0_tvvu + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if + ! det_mu_ex2 is in the list + if (nu2.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if + end do + end do + end do + ! now we do the double excitation E_tu E_vx |0> + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do v=1,n_act_orb + ipart=list_act(v) + do x=1,n_act_orb + ihole=list_act(x) + ! apply E_vx + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) + ! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> + if (ierr1.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex1,det_mu_ex11,N_int) + call det_copy(det_mu_ex1,det_mu_ex12,N_int) + call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11& + ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) + if (nu11.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate)& + *phase11*phase1 + end do + end if + if (nu12.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate)& + *phase12*phase1 + end do + end if + end do + end do + end if + + ! we apply E_tu to the second resultant determinant + if (ierr2.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex2,det_mu_ex21,N_int) + call det_copy(det_mu_ex2,det_mu_ex22,N_int) + call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21& + ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) + if (nu21.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate)& + *phase21*phase2 + end do + end if + if (nu22.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate)& + *phase22*phase2 + end do + end if + end do + end do + end if + + end do + end do + end do + + ! we average by just dividing by the number of states + do x=1,n_act_orb + do v=1,n_act_orb + do u=1,n_act_orb + do t=1,n_act_orb + P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) + end do + end do + end do + end do + END_PROVIDER diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f index c8e6c08a..adf90196 100644 --- a/src/casscf/det_manip.irp.f +++ b/src/casscf/det_manip.irp.f @@ -1,131 +1,130 @@ -! -*- F90 -*- -use bitmasks ! you need to include the bitmasks_module.f90 features +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 - 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 +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 + 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 -! if (found) then -! if (nu.eq.-1) then -! write(6,*) ' image not found in the list, thus nu = ',nu -! else -! write(6,*) ' found in the list as No ',nu,' phase = ',phase -! end if -! end if - end if -! -! we found the new string, the phase, and possibly the number in the list -! - end subroutine do_signed_mono_excitation + end do + end if + end do + ! if (found) then + ! if (nu.eq.-1) then + ! write(6,*) ' image not found in the list, thus nu = ',nu + ! else + ! write(6,*) ' found in the list as No ',nu,' phase = ',phase + ! end if + ! end if + 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_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 +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 - end subroutine do_spinfree_mono_excitation +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_wdens.irp.f b/src/casscf/driver_wdens.irp.f index 263e8441..5a3863a3 100644 --- a/src/casscf/driver_wdens.irp.f +++ b/src/casscf/driver_wdens.irp.f @@ -7,58 +7,13 @@ write(6,*) ' generating natural orbitals ' write(6,*) write(6,*) - call trf_to_natorb write(6,*) ' all data available ! ' write(6,*) ' writing out files ' - open(unit=12,file='D0tu.dat',form='formatted',status='unknown') - do p=1,n_act_orb - do q=1,n_act_orb - if (abs(D0tu(p,q)).gt.1.D-12) then - write(12,'(2i8,E20.12)') p,q,D0tu(p,q) - end if - end do - end do - close(12) - + call trf_to_natorb real*8 :: approx,np,nq,nr,ns logical :: lpq,lrs,lps,lqr - open(unit=12,file='P0tuvx.dat',form='formatted',status='unknown') - do p=1,n_act_orb - np=D0tu(p,p) - do q=1,n_act_orb - lpq=p.eq.q - nq=D0tu(q,q) - do r=1,n_act_orb - lqr=q.eq.r - nr=D0tu(r,r) - do s=1,n_act_orb - lrs=r.eq.s - lps=p.eq.s - approx=0.D0 - if (lpq.and.lrs) then - if (lqr) then -! pppp - approx=0.5D0*np*(np-1.D0) - else -! pprr - approx=0.5D0*np*nr - end if - else - if (lps.and.lqr.and..not.lpq) then -! pqqp - approx=-0.25D0*np*nq - end if - end if - if (abs(P0tuvx(p,q,r,s)).gt.1.D-12) then - write(12,'(4i4,2E20.12)') p,q,r,s,P0tuvx(p,q,r,s),approx - end if - end do - end do - end do - end do - close(12) open(unit=12,form='formatted',status='unknown',file='onetrf.tmp') indx=0 @@ -74,63 +29,6 @@ logical :: lpq,lrs,lps,lqr close(12) - open(unit=12,form='formatted',status='unknown',file='bielec_PQxx.tmp') - indx=0 - do p=1,mo_num - do q=p,mo_num - do r=1,n_core_orb+n_act_orb - do s=r,n_core_orb+n_act_orb - if (abs(bielec_PQxxtmp(p,q,r,s)).gt.1.D-12) then - write(12,'(4i8,E20.12)') p,q,r,s,bielec_PQxxtmp(p,q,r,s) - indx+=1 - end if - end do - end do - end do - end do - write(6,*) ' wrote ',indx,' integrals (PQ|xx)' - close(12) - - open(unit=12,form='formatted',status='unknown',file='bielec_PxxQ.tmp') - indx=0 - do p=1,mo_num - do q=1,n_core_orb+n_act_orb - do r=q,n_core_orb+n_act_orb -integer ::s_start - if (q.eq.r) then - s_start=p - else - s_start=1 - end if - do s=s_start,mo_num - if (abs(bielec_PxxQtmp(p,q,r,s)).gt.1.D-12) then - write(12,'(4i8,E20.12)') p,q,r,s,bielec_PxxQtmp(p,q,r,s) - indx+=1 - end if - end do - end do - end do - end do - write(6,*) ' wrote ',indx,' integrals (Px|xQ)' - close(12) - - open(unit=12,form='formatted',status='unknown',file='bielecCI.tmp') - indx=0 - do p=1,n_act_orb - do q=p,n_act_orb - do r=1,n_act_orb - do s=1,mo_num - if (abs(bielecCItmp(p,q,r,s)).gt.1.D-12) then - write(12,'(4i8,E20.12)') p,q,r,s,bielecCItmp(p,q,r,s) - indx+=1 - end if - end do - end do - end do - end do - write(6,*) ' wrote ',indx,' integrals (tu|xP)' - close(12) - write(6,*) write(6,*) ' creating new orbitals ' do i=1,mo_num diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f index d35d96ed..606bf12b 100644 --- a/src/casscf/gradient.irp.f +++ b/src/casscf/gradient.irp.f @@ -1,251 +1,249 @@ -! -*- F90 -*- - -use bitmasks ! you need to include the bitmasks_module.f90 features +use bitmasks BEGIN_PROVIDER [ integer, nMonoEx ] -BEGIN_DOC -! -END_DOC - implicit none - nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb - write(6,*) ' nMonoEx = ',nMonoEx + BEGIN_DOC + ! Number of single excitations + END_DOC + implicit none + nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb + write(6,*) ' nMonoEx = ',nMonoEx 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_orb - i=list_core(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_orb - i=list_core(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 + 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_orb + i=list_core(ii) + 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 - + indx+=1 + excit(1,indx)=i + excit(2,indx)=t + excit_class(indx)='c-a' + end do + end do + + do ii=1,n_core_orb + i=list_core(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) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad - write(6,*) - - + 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) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + + 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 -! write(6,*) -! write(6,*) ' mu = ',mu -! call print_det(det_mu,N_int) -! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin -! call print_det(det_mu_ex,N_int) - 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 -! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res - end if +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 + ! write(6,*) + ! write(6,*) ' mu = ',mu + ! call print_det(det_mu,N_int) + ! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin + ! call print_det(det_mu_ex,N_int) + 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 do - -! state-averaged gradient - res*=2.D0/dble(N_states) - - end subroutine calc_grad_elem + ! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res + 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_orb - do t=1,n_act_orb - indx+=1 - gradvec2(indx)=gradvec_it(i,t) - end do - end do - - do i=1,n_core_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) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad - write(6,*) - + 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_orb + do t=1,n_act_orb + indx+=1 + gradvec2(indx)=gradvec_it(i,t) + end do + end do + + do i=1,n_core_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) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) + END_PROVIDER - real*8 function gradvec_it(i,t) -BEGIN_DOC -! the orbital gradient core -> active -! we assume natural orbitals -END_DOC - implicit none - integer :: i,t +real*8 function gradvec_it(i,t) + BEGIN_DOC + ! the orbital gradient core -> 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(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_orb + do y=1,n_act_orb + y3=y+n_core_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 - integer :: ii,tt,v,vv,x,y - integer :: x3,y3 +real*8 function gradvec_ia(i,a) + BEGIN_DOC + ! the orbital gradient core -> virtual + END_DOC + implicit none + integer :: i,a,ii,aa + + ii=list_core(i) + aa=list_virt(a) + gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) + gradvec_ia*=2.D0 + +end function gradvec_ia - ii=list_core(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_orb - do y=1,n_act_orb - y3=y+n_core_orb - gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx(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 -> virtual -END_DOC - implicit none - integer :: i,a,ii,aa - - ii=list_core(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(x,y,v,aa) - end do - end do - end do - gradvec_ta*=2.D0 - - end function gradvec_ta +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/hessian.irp.f b/src/casscf/hessian.irp.f index 4603d11e..65734a25 100644 --- a/src/casscf/hessian.irp.f +++ b/src/casscf/hessian.irp.f @@ -1,639 +1,637 @@ -! -*- F90 -*- - -use bitmasks ! you need to include the bitmasks_module.f90 features +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 - - write(6,*) ' providing Hessian matrix hessmat ' - write(6,*) ' nMonoEx = ',nMonoEx - - 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) -! write(6,*) ' Hessian ',ihole,'->',ipart & -! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',res - hessmat(indx,jndx)=res - hessmat(jndx,indx)=res - end do - end do - + 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 + + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + + 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) + ! write(6,*) ' Hessian ',ihole,'->',ipart & + ! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',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 & +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) + ! 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 + 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 & + 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) + 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 + 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 if end do - end do - -! state-averaged Hessian - res*=1.D0/dble(N_states) - - end subroutine calc_hess_elem + 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 - - real*8 :: hessmat_itju - real*8 :: hessmat_itja - real*8 :: hessmat_itua - real*8 :: hessmat_iajb - real*8 :: hessmat_iatb - real*8 :: hessmat_taub - - write(6,*) ' providing Hessian matrix hessmat2 ' - write(6,*) ' nMonoEx = ',nMonoEx - - indx=1 - do i=1,n_core_orb - do t=1,n_act_orb - jndx=indx - do j=i,n_core_orb - if (i.eq.j) then - ustart=t - else - ustart=1 - end if - do u=ustart,n_act_orb - hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) - hessmat2(jndx,indx)=hessmat2(indx,jndx) -! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) - jndx+=1 - end do - end do - do j=1,n_core_orb - do a=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - do u=1,n_act_orb - do a=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - indx+=1 + 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 + + real*8 :: hessmat_itju + real*8 :: hessmat_itja + real*8 :: hessmat_itua + real*8 :: hessmat_iajb + real*8 :: hessmat_iatb + real*8 :: hessmat_taub + + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + + indx=1 + do i=1,n_core_orb + do t=1,n_act_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + ustart=t + else + ustart=1 + end if + do u=ustart,n_act_orb + hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + ! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) + jndx+=1 end do - end do - - do i=1,n_core_orb + end do + do j=1,n_core_orb do a=1,n_virt_orb - jndx=indx - do j=i,n_core_orb - if (i.eq.j) then - bstart=a - else - bstart=1 - end if - do b=bstart,n_virt_orb - hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - do t=1,n_act_orb - do b=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - indx+=1 + hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 end do - end do - - do t=1,n_act_orb + end do + do u=1,n_act_orb do a=1,n_virt_orb - 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(indx,jndx)=hessmat_taub(t,a,u,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - indx+=1 + hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 end do - end do - + end do + indx+=1 + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do t=1,n_act_orb + do b=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + 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(indx,jndx)=hessmat_taub(t,a,u,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + END_PROVIDER - real*8 function hessmat_itju(i,t,j,u) -BEGIN_DOC -! the orbital hessian for core->act,core->act -! 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 - -! write(6,*) ' hessmat_itju ',i,t,j,u - ii=list_core(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(tt,i,i,tt)-bielec_pqxx(tt,tt,i,i)) - term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq(tt,i,i,tt) & - -bielec_pqxx(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(vv,xx,i,i) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & - bielec_pxxq(vv,i,i,xx)) - do y=1,n_act_orb - term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(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(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & - -bielec_PQxx(tt,uu,i,j)) - term-=occnum(tt)*Fipq(uu,tt) - term-=(occnum(tt)+occnum(uu)) & - *(3.D0*bielec_PxxQ(tt,i,i,uu)-bielec_PQxx(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(vv,xx,i,i) & - +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & - *bielec_pxxq(vv,i,i,xx)) - do y=1,n_act_orb - term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(u,v,y,xx) - end do - end do - end do -!!! write(6,*) ' direct diff ',i,t,j,u,term,term2 -!!! term=term2 - end if - else -! it/ju - jj=list_core(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(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & - -bielec_PQxx(tt,uu,i,j)) - term-=(occnum(tt)+occnum(uu))* & - (4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & - -bielec_PQxx(uu,tt,i,j)) - do v=1,n_act_orb - vv=list_act(v) - do x=1,n_act_orb +real*8 function hessmat_itju(i,t,j,u) + BEGIN_DOC + ! the orbital hessian for core->act,core->act + ! 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 + + ! write(6,*) ' hessmat_itju ',i,t,j,u + ii=list_core(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(u,t,v,x)*bielec_pqxx(vv,xx,i,j) & - +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & - *bielec_pxxq(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->act,core->virt -END_DOC - implicit none - integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y - real*8 :: term - -! write(6,*) ' hessmat_itja ',i,t,j,a -! it/ja - ii=list_core(i) - tt=list_act(t) - jj=list_core(j) - aa=list_virt(a) - term=2.D0*(4.D0*bielec_pxxq(aa,j,i,tt) & - -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt)) - term-=occnum(tt)*(4.D0*bielec_pxxq(aa,j,i,tt) & - -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(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 + 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-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,aa) + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) end do - end do end do - end if - term*=2.D0 - hessmat_itja=term + 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 + !!! write(6,*) ' direct diff ',i,t,j,u,term,term2 + !!! term=term2 + end if + else + ! it/ju + jj=list_core(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 - end function hessmat_itja +real*8 function hessmat_itja(i,t,j,a) + BEGIN_DOC + ! the orbital hessian for core->act,core->virt + END_DOC + implicit none + integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y + real*8 :: term + + ! write(6,*) ' hessmat_itja ',i,t,j,a + ! it/ja + ii=list_core(i) + tt=list_act(t) + jj=list_core(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->act,act->virt -END_DOC - implicit none - integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 - real*8 :: term +real*8 function hessmat_itua(i,t,u,a) + BEGIN_DOC + ! the orbital hessian for core->act,act->virt + END_DOC + implicit none + integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 + real*8 :: term + + ! write(6,*) ' hessmat_itua ',i,t,u,a + ii=list_core(i) + tt=list_act(t) + t3=t+n_core_orb + uu=list_act(u) + u3=u+n_core_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_orb + do x=1,n_act_orb + integer :: x3 + xx=list_act(x) + x3=x+n_core_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 -! write(6,*) ' hessmat_itua ',i,t,u,a - ii=list_core(i) - tt=list_act(t) - t3=t+n_core_orb - uu=list_act(u) - u3=u+n_core_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(aa,ii,t3,u3)-4.D0*bielec_pqxx(aa,uu,t3,i) & - +bielec_pxxq(aa,t3,u3,ii)) - do v=1,n_act_orb +real*8 function hessmat_iajb(i,a,j,b) + BEGIN_DOC + ! the orbital hessian for core->virt,core->virt + END_DOC + implicit none + integer :: i,a,j,b,ii,aa,jj,bb + real*8 :: term + ! write(6,*) ' hessmat_iajb ',i,a,j,b + + ii=list_core(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(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->virt,act->virt + END_DOC + implicit none + integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 + real*8 :: term + + ! write(6,*) ' hessmat_iatb ',i,a,t,b + ii=list_core(i) + aa=list_virt(a) + tt=list_act(t) + bb=list_virt(b) + t3=t+n_core_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 + + tt=list_act(t) + aa=list_virt(a) + if (t.eq.u) then + if (a.eq.b) then + ! ta/ta + t1=occnum(tt)*Fipq(aa,aa) + t2=0.D0 + t3=0.D0 + t1-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb vv=list_act(v) v3=v+n_core_orb do x=1,n_act_orb -integer :: x3 - xx=list_act(x) - x3=x+n_core_orb - term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,ii,v3,x3) & - +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & - *bielec_pqxx(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->virt,core->virt -END_DOC - implicit none - integer :: i,a,j,b,ii,aa,jj,bb - real*8 :: term -! write(6,*) ' hessmat_iajb ',i,a,j,b - - ii=list_core(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(aa,i,i,aa)-bielec_pqxx(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(aa,i,i,bb)-bielec_pqxx(aa,bb,i,i)) - end if - else -! ia/jb - jj=list_core(j) - bb=list_virt(b) - term=2.D0*(4.D0*bielec_pxxq(aa,i,j,bb)-bielec_pqxx(aa,bb,i,j) & - -bielec_pxxq(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->virt,act->virt -END_DOC - implicit none - integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 - real*8 :: term - -! write(6,*) ' hessmat_iatb ',i,a,t,b - ii=list_core(i) - aa=list_virt(a) - tt=list_act(t) - bb=list_virt(b) - t3=t+n_core_orb - term=occnum(tt)*(4.D0*bielec_pxxq(aa,i,t3,bb)-bielec_pxxq(aa,t3,i,bb) & - -bielec_pqxx(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(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 - - tt=list_act(t) - aa=list_virt(a) - if (t.eq.u) then - if (a.eq.b) then -! ta/ta - t1=occnum(tt)*Fipq(aa,aa) - t2=0.D0 - t3=0.D0 - t1-=occnum(tt)*Fipq(tt,tt) - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb - t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,aa,v3,x3) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & - bielec_pxxq(aa,x3,v3,aa)) - do y=1,n_act_orb - t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx) - end do - end do - end do - term=t1+t2+t3 -! write(6,*) ' Hess taub ',t,a,t1,t2,t3 - else - bb=list_virt(b) -! ta/tb b/=a - term=occnum(tt)*Fipq(aa,bb) - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb - term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,bb,v3,x3) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & - *bielec_pxxq(aa,x3,v3,bb)) - end do - end do - end if - else -! ta/ub t/=u - uu=list_act(u) - bb=list_virt(b) - term=0.D0 - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb xx=list_act(x) x3=x+n_core_orb - term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,bb,v3,x3) & - +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & - *bielec_pxxq(aa,x3,v3,bb)) - end do - end do - 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 x=1,n_act_orb - do y=1,n_act_orb - term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,uu) - term-=P0tuvx_no(u,v,x,y)*bielecCI(x,y,v,tt) - end do + t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(aa,x3,v3,aa)) + do y=1,n_act_orb + t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) end do - end do - end if - - end if - - term*=2.D0 - hessmat_taub=term - - end function hessmat_taub + end do + end do + term=t1+t2+t3 + ! write(6,*) ' Hess taub ',t,a,t1,t2,t3 + else + bb=list_virt(b) + ! ta/tb b/=a + term=occnum(tt)*Fipq(aa,bb) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & + *bielec_pxxq_no(aa,x3,v3,bb)) + end do + end do + end if + else + ! ta/ub t/=u + uu=list_act(u) + bb=list_virt(b) + term=0.D0 + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & + *bielec_pxxq_no(aa,x3,v3,bb)) + end do + end do + 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 x=1,n_act_orb + do y=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 - real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub - - indx=0 - do i=1,n_core_orb - do t=1,n_act_orb - indx+=1 - hessdiag(indx)=hessmat_itju(i,t,i,t) - end do - end do - - do i=1,n_core_orb - do a=1,n_virt_orb - indx+=1 - hessdiag(indx)=hessmat_iajb(i,a,i,a) - end do - end do - - do t=1,n_act_orb - do a=1,n_virt_orb - indx+=1 - hessdiag(indx)=hessmat_taub(t,a,t,a) - end do - end do - + BEGIN_DOC + ! the diagonal of the Hessian, needed for the Davidson procedure + END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + hessdiag(indx)=hessmat_itju(i,t,i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_iajb(i,a,i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_taub(t,a,t,a) + end do + end do + END_PROVIDER diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f index 301b1418..68845eb4 100644 --- a/src/casscf/mcscf_fock.irp.f +++ b/src/casscf/mcscf_fock.irp.f @@ -1,67 +1,80 @@ -! -*- F90 -*- - BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] -&BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] -BEGIN_DOC -! the inactive and the active Fock matrices, 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 - double precision, allocatable :: integrals_array1(:,:) - double precision, allocatable :: integrals_array2(:,:) - integer :: p,q,k,kk,t,tt,u,uu - allocate(integrals_array1(mo_num,mo_num)) - allocate(integrals_array2(mo_num,mo_num)) - +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(p,q) + end do + end do + + ! the inactive Fock matrix + do k=1,n_core_orb + kk=list_core(k) + do q=1,mo_num do p=1,mo_num - do q=1,mo_num - Fipq(p,q)=one_ints(p,q) - Fapq(p,q)=0.D0 - end do + Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q) end do - -! the inactive Fock matrix - do k=1,n_core_orb - kk=list_core(k) - do p=1,mo_num - do q=1,mo_num - Fipq(p,q)+=2.D0*bielec_pqxx(p,q,k,k) -bielec_pxxq(p,k,k,q) - end do - end do - end do - -! the active Fock matrix, D0tu is diagonal - do t=1,n_act_orb - tt=list_act(t) - do p=1,mo_num - do q=1,mo_num - Fapq(p,q)+=occnum(tt) & - *(bielec_pqxx(p,q,tt,tt)-0.5D0*bielec_pxxq(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 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 index a903260c..d2cc6736 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -1,548 +1,373 @@ -! -*- F90 -*- -! diagonalize D0tu -! save the diagonal somewhere, in inverse order -! 4-index-transform the 2-particle density matrix over active orbitals -! correct the bielectronic integrals -! correct the monoelectronic integrals -! put integrals on file, as well orbitals, and the density matrices -! - subroutine trf_to_natorb - implicit none - integer :: i,j,k,l,t,u,p,q,pp - real*8 :: eigval(n_act_orb),natorbsCI(n_act_orb,n_act_orb) - real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) + 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_orb + occnum(list_core(i))=2.D0 + end do + + do i=1,n_act_orb + occnum(list_act(i))=occ_act(n_act_orb-i+1) + end do - call lapack_diag(eigval,natorbsCI,D0tu,n_act_orb,n_act_orb) - write(6,*) ' found occupation numbers as ' - do i=1,n_act_orb - write(6,*) i,eigval(i) - end do + write(6,*) ' occupation numbers ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do - if (bavard) then -! - -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 - - do i=1,n_act_orb - do j=1,n_act_orb - D0tu(i,j)=0.D0 - end do -! fill occupation numbers in descending order - D0tu(i,i)=eigval(n_act_orb-i+1) - end do -! -! 4-index transformation of 2part matrices -! -! index per index -! first 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 - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(q,j,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(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 - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(j,q,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(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 - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(j,k,q,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(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 - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(j,k,l,q)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(j,k,l,p)=d(p) - end do - end do - end do - end do - write(6,*) ' transformed P0tuvx ' -! -! one-electron integrals -! - do i=1,mo_num - do j=1,mo_num - onetrf(i,j)=mo_one_e_integrals(i,j) - end do - end do -! 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 - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - onetrf(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 - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - onetrf(j,list_act(p))=d(p) - end do - end do - write(6,*) ' transformed onetrf ' -! -! Orbitals -! - do j=1,ao_num - do i=1,mo_num - NatOrbsFCI(j,i)=mo_coef(j,i) - end do - end do - - do j=1,ao_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - NatOrbsFCI(j,list_act(p))=d(p) - end do - end do - write(6,*) ' transformed orbitals ' -! -! now the bielectronic integrals -! -!!$ write(6,*) ' before the transformation ' -!!$integer :: kk,ll,ii,jj -!!$real*8 :: h1,h2,h3 -!!$ do i=1,n_act_orb -!!$ ii=list_act(i) -!!$ do j=1,n_act_orb -!!$ jj=list_act(j) -!!$ do k=1,n_act_orb -!!$ kk=list_act(k) -!!$ do l=1,n_act_orb -!!$ ll=list_act(l) -!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) -!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) -!!$ h3=bielecCItmp(i,j,k,ll) -!!$ if ((h1.ne.h2).or.(h1.ne.h3)) then -!!$ write(6,9901) i,j,k,l,h1,h2,h3 -!!$9901 format(' aie ',4i4,3E20.12) -!!$9902 format('correct',4i4,3E20.12) -!!$ else -!!$ write(6,9902) i,j,k,l,h1,h2,h3 -!!$ end if -!!$ end do -!!$ end do -!!$ end do -!!$ end do - - do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(list_act(q),j,k,l)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(list_act(q),k,l,j)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(list_act(p),j,k,l)=d1(p) - bielec_PxxQtmp(list_act(p),k,l,j)=d2(p) - end do - end do - end do - end do -! 2nd quarter - do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(j,list_act(q),k,l)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(j,k,l,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(j,list_act(p),k,l)=d1(p) - bielec_PxxQtmp(j,k,l,list_act(p))=d2(p) - end do - end do - end do - end do -! 3rd quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(j,k,n_core_orb+q,l)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(j,n_core_orb+q,l,k)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(j,k,n_core_orb+p,l)=d1(p) - bielec_PxxQtmp(j,n_core_orb+p,l,k)=d2(p) - end do - end do - end do - end do -! 4th quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(j,k,l,n_core_orb+q)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(j,l,n_core_orb+q,k)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(j,k,l,n_core_orb+p)=d1(p) - bielec_PxxQtmp(j,l,n_core_orb+p,k)=d2(p) - end do - end do - end do - end do - write(6,*) ' transformed PQxx and PxxQ ' -! -! and finally the bielecCI integrals -! - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(q,j,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(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,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(j,q,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(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,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(j,k,q,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(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 - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(j,k,l,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(j,k,l,list_act(p))=d(p) - end do - end do - end do - end do - write(6,*) ' transformed tuvP ' -! -! that's all -! -!!$ -!!$! test coherence of the bielectronic integals -!!$! PQxx = PxxQ = tuvP for some of the indices -!!$ write(6,*) ' after the transformation ' -!!$ do i=1,n_act_orb -!!$ ii=list_act(i) -!!$ do j=1,n_act_orb -!!$ jj=list_act(j) -!!$ do k=1,n_act_orb -!!$ kk=list_act(k) -!!$ do l=1,n_act_orb -!!$ ll=list_act(l) -!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) -!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) -!!$ h3=bielecCItmp(i,j,k,ll) -!!$ if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then -!!$ write(6,9901) i,j,k,l,h1,h1-h2,h1-h3 -!!$ else -!!$ write(6,9902) i,j,k,l,h1,h2,h3 -!!$ end if -!!$ end do -!!$ end do -!!$ end do -!!$ end do - -! we recalculate total energies - write(6,*) - write(6,*) ' recalculating energies after the transformation ' - write(6,*) - write(6,*) - real*8 :: e_one_all - real*8 :: e_two_all - integer :: ii - integer :: jj - integer :: t3 - integer :: tt - integer :: u3 - integer :: uu - integer :: v - integer :: v3 - integer :: vv - integer :: x - integer :: x3 - integer :: xx - - e_one_all=0.D0 - e_two_all=0.D0 - do i=1,n_core_orb - ii=list_core(i) - e_one_all+=2.D0*onetrf(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - end do - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(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)*onetrf(tt,uu) - do v=1,n_act_orb - v3=v+n_core_orb - do x=1,n_act_orb - x3=x+n_core_orb - e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) - end do - end do - end do - end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all - ecore =nuclear_repulsion - ecore_bis=nuclear_repulsion - do i=1,n_core_orb - ii=list_core(i) - ecore +=2.D0*onetrf(ii,ii) - ecore_bis+=2.D0*onetrf(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(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_orb - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - eone +=D0tu(t,u)*onetrf(tt,uu) - eone_bis+=D0tu(t,u)*onetrf(tt,uu) - do i=1,n_core_orb - ii=list_core(i) - eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(tt,ii,i,u3)) - eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & - -bielec_PxxQtmp(tt,i,i,uu)) - end do - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb -real*8 :: h1,h2,h3 - h1=bielec_PQxxtmp(tt,uu,v3,x3) - h2=bielec_PxxQtmp(tt,u3,v3,xx) - h3=bielecCItmp(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 ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) 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 - - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - - end subroutine trf_to_natorb - - BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] -&BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] 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 + + call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) + + write(6,*) ' found occupation numbers as ' + do i=1,n_act_orb + write(6,*) i,occ_act(i) + end do + + if (bavard) then + ! + + 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,pp + 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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=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 + write(6,*) ' transformed P0tuvx ' + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] + implicit none + BEGIN_DOC + ! Transformed one-e integrals + END_DOC + integer :: i,j, p, pp, q + real*8 :: d(n_act_orb) + onetrf(:,:)=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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(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 + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed onetrf ' +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] + implicit none + BEGIN_DOC +! FCI natural orbitals + END_DOC + integer :: i,j, p, pp, q + real*8 :: d(n_act_orb) + + NatOrbsFCI(:,:)=mo_coef(:,:) + + do j=1,ao_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + NatOrbsFCI(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed orbitals ' +END_PROVIDER + + + + + + +subroutine trf_to_natorb() + implicit none + BEGIN_DOC + ! save the diagonal somewhere, in inverse order + ! 4-index-transform the 2-particle density matrix over active orbitals + ! correct the bielectronic integrals + ! correct the monoelectronic integrals + ! put integrals on file, as well orbitals, and the density matrices + ! + END_DOC + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) + + ! we recalculate total energies + write(6,*) + write(6,*) ' recalculating energies after the transformation ' + write(6,*) + write(6,*) + real*8 :: e_one_all + real*8 :: e_two_all + integer :: ii + integer :: jj + integer :: t3 + integer :: tt + integer :: u3 + integer :: uu + integer :: v + integer :: v3 + integer :: vv + integer :: x + integer :: x3 + integer :: xx + + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_orb + ii=list_core(i) + e_one_all+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + e_two_all += occnum(list_act(t)) * & + (2.d0*bielec_PQxx_no(tt,tt,i,i) - bielec_PQxx_no(tt,ii,i,t3)) + end do + end do + + + + do t=1,n_act_orb + tt=list_act(t) + e_one_all += occnum(list_act(t))*onetrf(tt,tt) + do u=1,n_act_orb + uu=list_act(u) + do v=1,n_act_orb + v3=v+n_core_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx_no(t,u,v,x)*bielec_PQxx_no(tt,uu,v3,x3) + end do + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(i) + ecore +=2.D0*onetrf(ii,ii) + ecore_bis+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQ_no(ii,i,j,jj)-bielec_PxxQ_no(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_orb + eone += occnum(list_act(t))*onetrf(tt,tt) + eone_bis += occnum(list_act(t))*onetrf(tt,tt) + do i=1,n_core_orb + ii=list_core(i) + eone += occnum(list_act(t)) * & + (2.D0*bielec_PQxx_no(tt,tt,i,i ) - bielec_PQxx_no(tt,ii,i,t3)) + eone_bis += occnum(list_act(t)) * & + (2.D0*bielec_PxxQ_no(tt,t3,i,ii) - bielec_PxxQ_no(tt,i ,i,tt)) + end do + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + real*8 :: h1,h2,h3 + h1=bielec_PQxx_no(tt,uu,v3,x3) + h2=bielec_PxxQ_no(tt,u3,v3,xx) + h3=bielecCI_no(t,u,v,xx) + etwo +=P0tuvx_no(t,u,v,x)*h1 + etwo_bis+=P0tuvx_no(t,u,v,x)*h2 + etwo_ter+=P0tuvx_no(t,u,v,x)*h3 + if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) 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 + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + SOFT_TOUCH ecore ecore_bis eone eone_bis etwo etwo_bis etwo_ter + +end subroutine trf_to_natorb + diff --git a/src/casscf/natorb_casscf.irp.f b/src/casscf/natorb_casscf.irp.f deleted file mode 100644 index 0a818a34..00000000 --- a/src/casscf/natorb_casscf.irp.f +++ /dev/null @@ -1,65 +0,0 @@ -! -*- F90 -*- -BEGIN_PROVIDER [real*8, occnum, (mo_num)] - implicit none - integer :: i,kk,j - logical :: lread - real*8 :: rdum - do i=1,mo_num - occnum(i)=0.D0 - end do - do i=1,n_core_orb - occnum(list_core(i))=2.D0 - end do - - open(unit=12,file='D0tu.dat',form='formatted',status='old') - lread=.true. - do while (lread) - read(12,*,iostat=kk) i,j,rdum - if (kk.ne.0) then - lread=.false. - else - if (i.eq.j) then - occnum(list_act(i))=rdum - else - write(6,*) ' WARNING - no natural orbitals !' - write(6,*) i,j,rdum - end if - end if - end do - close(12) - write(6,*) ' read occupation numbers ' - do i=1,mo_num - write(6,*) i,occnum(i) - end do - -END_PROVIDER - -BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - integer :: i,j,k,l,kk - real*8 :: rdum - logical :: lread - - do i=1,n_act_orb - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - P0tuvx_no(l,k,j,i)=0.D0 - end do - end do - end do - end do - - open(unit=12,file='P0tuvx.dat',form='formatted',status='old') - lread=.true. - do while (lread) - read(12,*,iostat=kk) i,j,k,l,rdum - if (kk.ne.0) then - lread=.false. - else - P0tuvx_no(i,j,k,l)=rdum - end if - end do - close(12) - write(6,*) ' read the 2-particle density matrix ' -END_PROVIDER diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f index 8734006e..780cd543 100644 --- a/src/casscf/tot_en.irp.f +++ b/src/casscf/tot_en.irp.f @@ -1,4 +1,3 @@ -! -*- F90 -*- BEGIN_PROVIDER [real*8, etwo] &BEGIN_PROVIDER [real*8, eone] &BEGIN_PROVIDER [real*8, eone_bis] @@ -6,117 +5,117 @@ &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_orb - ii=list_core(i) - e_one_all+=2.D0*mo_one_e_integrals(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - end do - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(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_orb - do x=1,n_act_orb - x3=x+n_core_orb - e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) - end do - end do - end do - end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all - ecore =nuclear_repulsion - ecore_bis=nuclear_repulsion - do i=1,n_core_orb - ii=list_core(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_orb - jj=list_core(j) - ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(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_orb - do u=1,n_act_orb + 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_orb + ii=list_core(i) + e_one_all+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(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_orb + do u=1,n_act_orb uu=list_act(u) u3=u+n_core_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_orb - ii=list_core(i) - eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(tt,ii,i,u3)) - eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & - -bielec_PxxQtmp(tt,i,i,uu)) + 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_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3) end do - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(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_orb + jj=list_core(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_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_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_orb + ii=list_core(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_orb + do x=1,n_act_orb xx=list_act(x) x3=x+n_core_orb -real*8 :: h1,h2,h3 - h1=bielec_PQxxtmp(tt,uu,v3,x3) - h2=bielec_PxxQtmp(tt,u3,v3,xx) - h3=bielecCItmp(t,u,v,xx) + 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) + 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 - - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - write(6,*) ' nuclear (qp) = ',nuclear_repulsion - write(6,*) ' core energy (qp) = ',core_energy - write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) - write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) - write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) - write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) - + end do + end do + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + write(6,*) ' nuclear (qp) = ',nuclear_repulsion + write(6,*) ' core energy (qp) = ',core_energy + write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) + write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) + write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) + write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) + END_PROVIDER - - + + From 6531181316c131f30d54a3653d17b597c0a43f3b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 25 Jun 2019 19:10:50 +0200 Subject: [PATCH 12/28] More cleaning --- src/casscf/casscf.irp.f | 8 +++++- src/casscf/driver_wdens.irp.f | 52 ----------------------------------- src/casscf/mcscf_fock.irp.f | 2 +- src/casscf/natorb.irp.f | 26 +++++++++--------- src/casscf/one_ints.irp.f | 26 ------------------ 5 files changed, 21 insertions(+), 93 deletions(-) delete mode 100644 src/casscf/driver_wdens.irp.f delete mode 100644 src/casscf/one_ints.irp.f diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index b55c4c3b..1737c852 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -19,7 +19,13 @@ subroutine run N_det = 1 TOUCH N_det psi_det psi_coef call run_cipsi - call driver_wdens + + write(6,*) ' total energy = ',eone+etwo+ecore + mo_label = "MCSCF" + mo_label = "Natural" + mo_coef(:,:) = NatOrbsFCI(:,:) + call save_mos + call driver_optorb energy_old = energy energy = eone+etwo+ecore diff --git a/src/casscf/driver_wdens.irp.f b/src/casscf/driver_wdens.irp.f deleted file mode 100644 index 5a3863a3..00000000 --- a/src/casscf/driver_wdens.irp.f +++ /dev/null @@ -1,52 +0,0 @@ - subroutine driver_wdens - implicit none - integer :: istate,p,q,r,s,indx,i,j - - - write(6,*) ' total energy = ',eone+etwo+ecore - write(6,*) ' generating natural orbitals ' - write(6,*) - write(6,*) - - write(6,*) ' all data available ! ' - write(6,*) ' writing out files ' - - call trf_to_natorb -real*8 :: approx,np,nq,nr,ns -logical :: lpq,lrs,lps,lqr - - open(unit=12,form='formatted',status='unknown',file='onetrf.tmp') - indx=0 - do q=1,mo_num - do p=q,mo_num - if (abs(onetrf(p,q)).gt.1.D-12) then - write(12,'(2i6,E20.12)') p,q,onetrf(p,q) - indx+=1 - end if - end do - end do - write(6,*) ' wrote ',indx,' mono-electronic integrals' - close(12) - - - write(6,*) - write(6,*) ' creating new orbitals ' - do i=1,mo_num - write(6,*) ' Orbital No ',i - write(6,'(5F14.6)') (NatOrbsFCI(j,i),j=1,mo_num) - write(6,*) - end do - - mo_label = "MCSCF" - mo_label = "Natural" - do i=1,mo_num - do j=1,ao_num - mo_coef(j,i)=NatOrbsFCI(j,i) - end do - end do - call save_mos - - write(6,*) ' ... done ' - - end - diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f index 68845eb4..84b87248 100644 --- a/src/casscf/mcscf_fock.irp.f +++ b/src/casscf/mcscf_fock.irp.f @@ -7,7 +7,7 @@ BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] do q=1,mo_num do p=1,mo_num - Fipq(p,q)=one_ints(p,q) + Fipq(p,q)=one_ints_no(p,q) end do end do diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index d2cc6736..00c9564c 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -158,14 +158,14 @@ END_PROVIDER -BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] +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, pp, q real*8 :: d(n_act_orb) - onetrf(:,:)=mo_one_e_integrals(:,:) + one_ints_no(:,:)=mo_one_e_integrals(:,:) ! 1st half-trf do j=1,mo_num @@ -175,11 +175,11 @@ BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) + d(pp)+=one_ints_no(list_act(q),j)*natorbsCI(q,p) end do end do do p=1,n_act_orb - onetrf(list_act(p),j)=d(p) + one_ints_no(list_act(p),j)=d(p) end do end do @@ -191,14 +191,14 @@ BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) + d(pp)+=one_ints_no(j,list_act(q))*natorbsCI(q,p) end do end do do p=1,n_act_orb - onetrf(j,list_act(p))=d(p) + one_ints_no(j,list_act(p))=d(p) end do end do - write(6,*) ' transformed onetrf ' + write(6,*) ' transformed one_ints ' END_PROVIDER @@ -271,7 +271,7 @@ subroutine trf_to_natorb() e_two_all=0.D0 do i=1,n_core_orb ii=list_core(i) - e_one_all+=2.D0*onetrf(ii,ii) + e_one_all+=2.D0*one_ints_no(ii,ii) do j=1,n_core_orb jj=list_core(j) e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) @@ -288,7 +288,7 @@ subroutine trf_to_natorb() do t=1,n_act_orb tt=list_act(t) - e_one_all += occnum(list_act(t))*onetrf(tt,tt) + e_one_all += occnum(list_act(t))*one_ints_no(tt,tt) do u=1,n_act_orb uu=list_act(u) do v=1,n_act_orb @@ -306,8 +306,8 @@ subroutine trf_to_natorb() ecore_bis=nuclear_repulsion do i=1,n_core_orb ii=list_core(i) - ecore +=2.D0*onetrf(ii,ii) - ecore_bis+=2.D0*onetrf(ii,ii) + ecore +=2.D0*one_ints_no(ii,ii) + ecore_bis+=2.D0*one_ints_no(ii,ii) do j=1,n_core_orb jj=list_core(j) ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) @@ -322,8 +322,8 @@ subroutine trf_to_natorb() do t=1,n_act_orb tt=list_act(t) t3=t+n_core_orb - eone += occnum(list_act(t))*onetrf(tt,tt) - eone_bis += occnum(list_act(t))*onetrf(tt,tt) + eone += occnum(list_act(t))*one_ints_no(tt,tt) + eone_bis += occnum(list_act(t))*one_ints_no(tt,tt) do i=1,n_core_orb ii=list_core(i) eone += occnum(list_act(t)) * & diff --git a/src/casscf/one_ints.irp.f b/src/casscf/one_ints.irp.f deleted file mode 100644 index a802f644..00000000 --- a/src/casscf/one_ints.irp.f +++ /dev/null @@ -1,26 +0,0 @@ -! -*- F90 -*- -BEGIN_PROVIDER [real*8, one_ints, (mo_num,mo_num)] - implicit none - integer :: i,j,kk - logical :: lread - real*8 :: rdum - do i=1,mo_num - do j=1,mo_num - one_ints(i,j)=0.D0 - end do - end do - open(unit=12,file='onetrf.tmp',status='old',form='formatted') - lread=.true. - do while (lread) - read(12,*,iostat=kk) i,j,rdum - if (kk.ne.0) then - lread=.false. - else - one_ints(i,j)=rdum - one_ints(j,i)=rdum - end if - end do - close(12) - write(6,*) ' read MCSCF natural one-electron integrals ' -END_PROVIDER - From 5902f3231eef21afffa86f40d75093c499748195 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 25 Jun 2019 23:10:19 +0200 Subject: [PATCH 13/28] Cleaned neworbs --- src/casscf/casscf.irp.f | 4 - src/casscf/neworbs.irp.f | 360 +++++++++++++++++---------------------- 2 files changed, 155 insertions(+), 209 deletions(-) diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 1737c852..16c34131 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -21,10 +21,6 @@ subroutine run call run_cipsi write(6,*) ' total energy = ',eone+etwo+ecore - mo_label = "MCSCF" - mo_label = "Natural" - mo_coef(:,:) = NatOrbsFCI(:,:) - call save_mos call driver_optorb energy_old = energy diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index 6d63a86e..fd115880 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -1,222 +1,172 @@ -! -*- F90 -*- BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] - implicit none - 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+1 - write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) - end do - end if - - + 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+1 + 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)] - END_PROVIDER + 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 - integer :: ierr,matz,i - real*8 :: c0 - - call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) - 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) - energy_improvement = SXeigenval(1) - -integer :: best_vector -real*8 :: best_overlap - best_overlap=0.D0 - 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 - - write(6,*) ' SXdiag : eigenvalue for best overlap with ' - write(6,*) ' previous orbitals = ',SXeigenval(best_vector) - energy_improvement = SXeigenval(best_vector) - - c0=SXeigenvec(1,best_vector) - write(6,*) ' weight of the 1st element ',c0 - do i=1,nMonoEx+1 - SXvector(i)=SXeigenvec(i,best_vector)/c0 -! write(6,*) ' component No ',i,' : ',SXvector(i) - end do - + implicit none + BEGIN_DOC + ! Best eigenvector of the single-excitation matrix + END_DOC + integer :: ierr,matz,i + real*8 :: c0 + + 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) + energy_improvement = SXeigenval(1) + + integer :: best_vector + real*8 :: best_overlap + best_overlap=0.D0 + 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 + + write(6,*) ' SXdiag : eigenvalue for best overlap with ' + write(6,*) ' previous orbitals = ',SXeigenval(best_vector) + energy_improvement = SXeigenval(best_vector) + + c0=SXeigenvec(1,best_vector) + write(6,*) ' weight of the 1st element ',c0 + do i=1,nMonoEx+1 + SXvector(i)=SXeigenvec(i,best_vector)/c0 + ! write(6,*) ' component No ',i,' : ',SXvector(i) + end do + END_PROVIDER BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ] - implicit none - integer :: i,j,ialph - -! form the exponential of the Orbital rotations - call get_orbrotmat -! form the new orbitals - do i=1,ao_num - do j=1,mo_num - NewOrbs(i,j)=0.D0 - end do - end do - - do ialph=1,ao_num - do i=1,mo_num - wrkline(i)=mo_coef(ialph,i) - end do - do i=1,mo_num - do j=1,mo_num - NewOrbs(ialph,i)+=Umat(i,j)*wrkline(j) - end do - end do - end do - + 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, Tpotmat, (mo_num,mo_num) ] -&BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] -&BEGIN_PROVIDER [real*8, wrkline, (mo_num) ] -&BEGIN_PROVIDER [real*8, Tmat, (mo_num,mo_num) ] -END_PROVIDER - - subroutine get_orbrotmat - implicit none - integer :: i,j,indx,k,iter,t,a,ii,tt,aa - real*8 :: sum - logical :: converged - - -! the orbital rotation matrix T - do i=1,mo_num - do j=1,mo_num - Tmat(i,j)=0.D0 - Umat(i,j)=0.D0 - Tpotmat(i,j)=0.D0 - end do - Tpotmat(i,i)=1.D0 - end do - - indx=1 - do i=1,n_core_orb - ii=list_core(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_orb - ii=list_core(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 - - write(6,*) ' the T matrix ' - do indx=1,nMonoEx - i=excit(1,indx) - j=excit(2,indx) -! if (abs(Tmat(i,j)).gt.1.D0) then -! write(6,*) ' setting matrix element ',i,j,' of ',Tmat(i,j),' to ' & -! , sign(1.D0,Tmat(i,j)) -! Tmat(i,j)=sign(1.D0,Tmat(i,j)) -! Tmat(j,i)=-Tmat(i,j) -! end if - if (abs(Tmat(i,j)).gt.1.D-9) write(6,9901) i,j,excit_class(indx),Tmat(i,j) - 9901 format(' ',i4,' -> ',i4,' (',A3,') : ',E14.6) - end do - - write(6,*) - write(6,*) ' forming the matrix exponential ' - write(6,*) -! form the exponential - iter=0 - converged=.false. - do while (.not.converged) - iter+=1 -! add the next term - do i=1,mo_num - do j=1,mo_num - Umat(i,j)+=Tpotmat(i,j) - end do - end do -! next power of T, we multiply Tpotmat with Tmat/iter - do i=1,mo_num - do j=1,mo_num - wrkline(j)=Tpotmat(i,j)/dble(iter) - Tpotmat(i,j)=0.D0 - end do - do j=1,mo_num - do k=1,mo_num - Tpotmat(i,j)+=wrkline(k)*Tmat(k,j) - end do - end do - end do -! Convergence test - sum=0.D0 - do i=1,mo_num - do j=1,mo_num - sum+=abs(Tpotmat(i,j)) - end do - end do - write(6,*) ' Iteration No ',iter,' Sum = ',sum - if (sum.lt.1.D-6) then - converged=.true. - end if - if (iter.ge.NItExpMax) then - stop ' no convergence ' - end if - end do - write(6,*) - write(6,*) ' Converged ! ' - write(6,*) - - end subroutine get_orbrotmat - -BEGIN_PROVIDER [integer, NItExpMax] - NItExpMax=100 +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_orb + ii=list_core(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_orb + ii=list_core(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 + From a128c20afa8a3ed8573604f7e06130087e3bd6f3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 26 Jun 2019 00:51:47 +0200 Subject: [PATCH 14/28] CASSCF works --- src/casscf/bielec.irp.f | 3 - src/casscf/bielec_natorb.irp.f | 3 - src/casscf/casscf.irp.f | 28 ++++-- src/casscf/densities.irp.f | 8 +- src/casscf/driver_optorb.irp.f | 35 +------ src/casscf/gradient.irp.f | 23 ++--- src/casscf/hessian.irp.f | 23 ++--- src/casscf/natorb.irp.f | 167 +++------------------------------ src/casscf/neworbs.irp.f | 30 +++--- src/casscf/tot_en.irp.f | 20 ---- 10 files changed, 76 insertions(+), 264 deletions(-) diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index 9bb953f8..74351760 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -55,7 +55,6 @@ end do end do - write(6,*) ' provided integrals (PQ|xx) ' END_PROVIDER @@ -116,7 +115,6 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_a end do end do end do - write(6,*) ' provided integrals (Px|xQ) ' END_PROVIDER @@ -146,6 +144,5 @@ BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] end do end do end do - write(6,*) ' provided integrals (tu|xP) ' END_PROVIDER diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index 2f1e43eb..ca1c8e9d 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -84,7 +84,6 @@ end do end do end do - write(6,*) ' transformed PQxx' END_PROVIDER @@ -176,7 +175,6 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+ end do end do end do - write(6,*) ' transformed PxxQ ' END_PROVIDER @@ -267,7 +265,6 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] end do end do end do - write(6,*) ' transformed tuvP ' END_PROVIDER diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 16c34131..10a3e34a 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -12,20 +12,32 @@ subroutine run implicit none double precision :: energy_old, energy logical :: converged + integer :: iteration converged = .False. energy = 0.d0 -! do while (.not.converged) - N_det = 1 - TOUCH N_det psi_det psi_coef + mo_label = "MCSCF" + iteration = 1 + do while (.not.converged) call run_cipsi - write(6,*) ' total energy = ',eone+etwo+ecore - - call driver_optorb energy_old = energy energy = eone+etwo+ecore - converged = dabs(energy - energy_old) < 1.d-10 -! enddo + + 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 + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + N_det = 1 + iteration += 1 + FREE mo_integrals_map mo_two_e_integrals_in_map psi_det psi_coef + SOFT_TOUCH mo_coef N_det + enddo end diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 6e8065e2..8be2db6e 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -22,7 +22,9 @@ BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] integer :: ierr1,ierr2 real*8 :: cI_mu(N_states) - write(6,*) ' providing density matrices D0 and P0 ' + if (bavard) then + write(6,*) ' providing density matrix D0' + endif D0tu = 0.d0 @@ -90,7 +92,9 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] 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 - write(6,*) ' providing density matrices D0 and P0 ' + if (bavard) then + write(6,*) ' providing density matrix P0' + endif P0tuvx = 0.d0 diff --git a/src/casscf/driver_optorb.irp.f b/src/casscf/driver_optorb.irp.f index 591c90c9..2e3e02dc 100644 --- a/src/casscf/driver_optorb.irp.f +++ b/src/casscf/driver_optorb.irp.f @@ -1,32 +1,3 @@ - subroutine driver_optorb - implicit none - integer :: i,j - - write(6,*) -! write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) - write(6,*) ' energy improvement = ',energy_improvement -! write(6,*) ' new energy = ',psi_energy_with_nucl_rep(1)+energy_improvement - write(6,*) - - write(6,*) - write(6,*) ' creating new orbitals ' - do i=1,mo_num - write(6,*) ' Orbital No ',i - write(6,'(5F14.6)') (NewOrbs(j,i),j=1,mo_num) - write(6,*) - end do - - mo_label = "Natural" - do i=1,mo_num - do j=1,ao_num - mo_coef(j,i)=NewOrbs(j,i) - end do - end do - call save_mos - call map_deinit(mo_integrals_map) - FREE mo_integrals_map mo_coef mo_two_e_integrals_in_map - - write(6,*) - write(6,*) ' ... all done ' - - end +subroutine driver_optorb + implicit none +end diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f index 606bf12b..883a4665 100644 --- a/src/casscf/gradient.irp.f +++ b/src/casscf/gradient.irp.f @@ -6,7 +6,6 @@ BEGIN_PROVIDER [ integer, nMonoEx ] END_DOC implicit none nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb - write(6,*) ' nMonoEx = ',nMonoEx END_PROVIDER BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] @@ -87,9 +86,11 @@ BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)] norm_grad+=gradvec(indx)*gradvec(indx) end do norm_grad=sqrt(norm_grad) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad - write(6,*) + if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + endif END_PROVIDER @@ -118,17 +119,11 @@ subroutine calc_grad_elem(ihole,ipart,res) call do_signed_mono_excitation(det_mu,det_mu_ex,nu & ,ihole,ipart,ispin,phase,ierr) if (ierr.eq.1) then - ! write(6,*) - ! write(6,*) ' mu = ',mu - ! call print_det(det_mu,N_int) - ! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin - ! call print_det(det_mu_ex,N_int) 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 - ! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res end if end do end do @@ -176,9 +171,11 @@ BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] norm_grad+=gradvec2(indx)*gradvec2(indx) end do norm_grad=sqrt(norm_grad) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad - write(6,*) + if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) + endif END_PROVIDER diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f index 65734a25..e047c5fd 100644 --- a/src/casscf/hessian.irp.f +++ b/src/casscf/hessian.irp.f @@ -14,8 +14,10 @@ BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] character*3 :: iexc,jexc real*8 :: res - write(6,*) ' providing Hessian matrix hessmat ' - write(6,*) ' nMonoEx = ',nMonoEx + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + endif do indx=1,nMonoEx do jndx=1,nMonoEx @@ -32,8 +34,6 @@ BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] jpart=excit(2,jndx) jexc=excit_class(jndx) call calc_hess_elem(ihole,ipart,jhole,jpart,res) - ! write(6,*) ' Hessian ',ihole,'->',ipart & - ! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',res hessmat(indx,jndx)=res hessmat(jndx,indx)=res end do @@ -198,8 +198,10 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] real*8 :: hessmat_iatb real*8 :: hessmat_taub - write(6,*) ' providing Hessian matrix hessmat2 ' - write(6,*) ' nMonoEx = ',nMonoEx + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + endif indx=1 do i=1,n_core_orb @@ -214,7 +216,6 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] do u=ustart,n_act_orb hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) hessmat2(jndx,indx)=hessmat2(indx,jndx) - ! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) jndx+=1 end do end do @@ -294,7 +295,6 @@ real*8 function hessmat_itju(i,t,j,u) integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj real*8 :: term,t2 - ! write(6,*) ' hessmat_itju ',i,t,j,u ii=list_core(i) tt=list_act(t) if (i.eq.j) then @@ -340,8 +340,6 @@ real*8 function hessmat_itju(i,t,j,u) end do end do end do - !!! write(6,*) ' direct diff ',i,t,j,u,term,term2 - !!! term=term2 end if else ! it/ju @@ -382,7 +380,6 @@ real*8 function hessmat_itja(i,t,j,a) integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y real*8 :: term - ! write(6,*) ' hessmat_itja ',i,t,j,a ! it/ja ii=list_core(i) tt=list_act(t) @@ -416,7 +413,6 @@ real*8 function hessmat_itua(i,t,u,a) integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 real*8 :: term - ! write(6,*) ' hessmat_itua ',i,t,u,a ii=list_core(i) tt=list_act(t) t3=t+n_core_orb @@ -457,7 +453,6 @@ real*8 function hessmat_iajb(i,a,j,b) implicit none integer :: i,a,j,b,ii,aa,jj,bb real*8 :: term - ! write(6,*) ' hessmat_iajb ',i,a,j,b ii=list_core(i) aa=list_virt(a) @@ -495,7 +490,6 @@ real*8 function hessmat_iatb(i,a,t,b) integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 real*8 :: term - ! write(6,*) ' hessmat_iatb ',i,a,t,b ii=list_core(i) aa=list_virt(a) tt=list_act(t) @@ -552,7 +546,6 @@ real*8 function hessmat_taub(t,a,u,b) end do end do term=t1+t2+t3 - ! write(6,*) ' Hess taub ',t,a,t1,t2,t3 else bb=list_virt(b) ! ta/tb b/=a diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index 00c9564c..52cd3747 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -14,10 +14,12 @@ occnum(list_act(i))=occ_act(n_act_orb-i+1) end do - write(6,*) ' occupation numbers ' - do i=1,mo_num - write(6,*) i,occnum(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 @@ -32,14 +34,12 @@ END_PROVIDER call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) - write(6,*) ' found occupation numbers as ' - do i=1,n_act_orb - write(6,*) i,occ_act(i) - end do - 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 @@ -152,7 +152,6 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] end do end do end do - write(6,*) ' transformed P0tuvx ' END_PROVIDER @@ -198,7 +197,6 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] one_ints_no(j,list_act(p))=d(p) end do end do - write(6,*) ' transformed one_ints ' END_PROVIDER @@ -226,148 +224,5 @@ BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] NatOrbsFCI(j,list_act(p))=d(p) end do end do - write(6,*) ' transformed orbitals ' END_PROVIDER - - - - - -subroutine trf_to_natorb() - implicit none - BEGIN_DOC - ! save the diagonal somewhere, in inverse order - ! 4-index-transform the 2-particle density matrix over active orbitals - ! correct the bielectronic integrals - ! correct the monoelectronic integrals - ! put integrals on file, as well orbitals, and the density matrices - ! - END_DOC - integer :: i,j,k,l,t,u,p,q,pp - real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) - - ! we recalculate total energies - write(6,*) - write(6,*) ' recalculating energies after the transformation ' - write(6,*) - write(6,*) - real*8 :: e_one_all - real*8 :: e_two_all - integer :: ii - integer :: jj - integer :: t3 - integer :: tt - integer :: u3 - integer :: uu - integer :: v - integer :: v3 - integer :: vv - integer :: x - integer :: x3 - integer :: xx - - e_one_all=0.D0 - e_two_all=0.D0 - do i=1,n_core_orb - ii=list_core(i) - e_one_all+=2.D0*one_ints_no(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) - end do - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - e_two_all += occnum(list_act(t)) * & - (2.d0*bielec_PQxx_no(tt,tt,i,i) - bielec_PQxx_no(tt,ii,i,t3)) - end do - end do - - - - do t=1,n_act_orb - tt=list_act(t) - e_one_all += occnum(list_act(t))*one_ints_no(tt,tt) - do u=1,n_act_orb - uu=list_act(u) - do v=1,n_act_orb - v3=v+n_core_orb - do x=1,n_act_orb - x3=x+n_core_orb - e_two_all +=P0tuvx_no(t,u,v,x)*bielec_PQxx_no(tt,uu,v3,x3) - end do - end do - end do - end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all - ecore =nuclear_repulsion - ecore_bis=nuclear_repulsion - do i=1,n_core_orb - ii=list_core(i) - ecore +=2.D0*one_ints_no(ii,ii) - ecore_bis+=2.D0*one_ints_no(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) - ecore_bis+=2.D0*bielec_PxxQ_no(ii,i,j,jj)-bielec_PxxQ_no(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_orb - eone += occnum(list_act(t))*one_ints_no(tt,tt) - eone_bis += occnum(list_act(t))*one_ints_no(tt,tt) - do i=1,n_core_orb - ii=list_core(i) - eone += occnum(list_act(t)) * & - (2.D0*bielec_PQxx_no(tt,tt,i,i ) - bielec_PQxx_no(tt,ii,i,t3)) - eone_bis += occnum(list_act(t)) * & - (2.D0*bielec_PxxQ_no(tt,t3,i,ii) - bielec_PxxQ_no(tt,i ,i,tt)) - end do - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb - real*8 :: h1,h2,h3 - h1=bielec_PQxx_no(tt,uu,v3,x3) - h2=bielec_PxxQ_no(tt,u3,v3,xx) - h3=bielecCI_no(t,u,v,xx) - etwo +=P0tuvx_no(t,u,v,x)*h1 - etwo_bis+=P0tuvx_no(t,u,v,x)*h2 - etwo_ter+=P0tuvx_no(t,u,v,x)*h3 - if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) 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 - - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - SOFT_TOUCH ecore ecore_bis eone eone_bis etwo etwo_bis etwo_ter - -end subroutine trf_to_natorb - diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index fd115880..fd94eb6a 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -51,14 +51,16 @@ END_PROVIDER integer :: ierr,matz,i real*8 :: c0 - 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) + 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 @@ -73,16 +75,20 @@ END_PROVIDER end if end do - write(6,*) ' SXdiag : eigenvalue for best overlap with ' - write(6,*) ' previous orbitals = ',SXeigenval(best_vector) energy_improvement = SXeigenval(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 + c0=SXeigenvec(1,best_vector) - write(6,*) ' weight of the 1st element ',c0 + do i=1,nMonoEx+1 SXvector(i)=SXeigenvec(i,best_vector)/c0 - ! write(6,*) ' component No ',i,' : ',SXvector(i) end do + END_PROVIDER diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f index 780cd543..ce787232 100644 --- a/src/casscf/tot_en.irp.f +++ b/src/casscf/tot_en.irp.f @@ -42,8 +42,6 @@ end do end do end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all ecore =nuclear_repulsion ecore_bis=nuclear_repulsion do i=1,n_core_orb @@ -98,24 +96,6 @@ end do end do - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - write(6,*) ' nuclear (qp) = ',nuclear_repulsion - write(6,*) ' core energy (qp) = ',core_energy - write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) - write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) - write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) - write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) - END_PROVIDER From 2ef517488c9038b641a4f3c95ca01cb2d38b7181 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 26 Jun 2019 01:43:16 +0200 Subject: [PATCH 15/28] Optimized 1rdm --- src/casscf/bavard.irp.f | 2 +- src/casscf/densities.irp.f | 73 ++++++-------------------------------- src/casscf/det_manip.irp.f | 9 ++--- 3 files changed, 13 insertions(+), 71 deletions(-) diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f index de71a346..a9797712 100644 --- a/src/casscf/bavard.irp.f +++ b/src/casscf/bavard.irp.f @@ -1,6 +1,6 @@ ! -*- F90 -*- BEGIN_PROVIDER [logical, bavard] bavard=.true. - bavard=.false. +! bavard=.false. END_PROVIDER diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 8be2db6e..9b8dba78 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -1,72 +1,19 @@ use bitmasks BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] - BEGIN_DOC - ! the first-order density matrix in the basis of the starting MOs - ! matrices 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 - ! - END_DOC implicit none - integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart - integer :: ierr - integer(bit_kind) :: det_mu(N_int,2) - integer(bit_kind) :: det_mu_ex(N_int,2) - integer(bit_kind) :: det_mu_ex1(N_int,2) - integer(bit_kind) :: det_mu_ex2(N_int,2) - real*8 :: phase1,phase2,term - integer :: nu1,nu2 - integer :: ierr1,ierr2 - real*8 :: cI_mu(N_states) + BEGIN_DOC + ! the first-order density matrix in the basis of the starting MOs. + ! matrix is state averaged. + END_DOC + integer :: t,u - if (bavard) then - write(6,*) ' providing density matrix D0' - endif - - D0tu = 0.d0 - - ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do + do u=1,n_act_orb do t=1,n_act_orb - ipart=list_act(t) - do u=1,n_act_orb - ihole=list_act(u) - ! apply E_tu - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) - ! det_mu_ex1 is in the list - if (nu1.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 - D0tu(t,u)+=term - end do - end if - ! det_mu_ex2 is in the list - if (nu2.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 - D0tu(t,u)+=term - end do - end if - end do - end do - end do - - ! we average by just dividing by the number of states - do x=1,n_act_orb - do v=1,n_act_orb - D0tu(v,x)*=1.0D0/dble(N_states) - end do - end do + 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 diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f index adf90196..d8c309a4 100644 --- a/src/casscf/det_manip.irp.f +++ b/src/casscf/det_manip.irp.f @@ -31,6 +31,8 @@ subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & ! get the number in the list found=.false. nu=0 + + !TODO BOTTLENECK do while (.not.found) nu+=1 if (nu.gt.N_det) then @@ -50,13 +52,6 @@ subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & end do end if end do - ! if (found) then - ! if (nu.eq.-1) then - ! write(6,*) ' image not found in the list, thus nu = ',nu - ! else - ! write(6,*) ' found in the list as No ',nu,' phase = ',phase - ! end if - ! end if end if ! ! we found the new string, the phase, and possibly the number in the list From 9bb66d5b3a08cef96c9422766e2ebb69ac31a2ac Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 27 Jun 2019 18:23:28 +0200 Subject: [PATCH 16/28] added the RDMS --- src/casscf/NEED | 1 + src/casscf/test_two_rdm.irp.f | 30 + .../two_e_density_matrix.irp.pouet | 609 ++++++++++++++++++ src/two_body_rdm/NEED | 1 + src/two_body_rdm/README.rst | 6 + src/two_body_rdm/ab_only_routines.irp.f | 402 ++++++++++++ src/two_body_rdm/all_2rdm_routines.irp.f | 443 +++++++++++++ src/two_body_rdm/routines_compute_2rdm.irp.f | 269 ++++++++ src/two_body_rdm/two_rdm.irp.f | 84 +++ 9 files changed, 1845 insertions(+) create mode 100644 src/casscf/test_two_rdm.irp.f create mode 100644 src/determinants/two_e_density_matrix.irp.pouet create mode 100644 src/two_body_rdm/NEED create mode 100644 src/two_body_rdm/README.rst create mode 100644 src/two_body_rdm/ab_only_routines.irp.f create mode 100644 src/two_body_rdm/all_2rdm_routines.irp.f create mode 100644 src/two_body_rdm/routines_compute_2rdm.irp.f create mode 100644 src/two_body_rdm/two_rdm.irp.f diff --git a/src/casscf/NEED b/src/casscf/NEED index d7aff476..c12b531e 100644 --- a/src/casscf/NEED +++ b/src/casscf/NEED @@ -1,3 +1,4 @@ cipsi selectors_full generators_cas +two_body_rdm diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f new file mode 100644 index 00000000..562d15a6 --- /dev/null +++ b/src/casscf/test_two_rdm.irp.f @@ -0,0 +1,30 @@ +program print_two_rdm + implicit none + integer :: i,j,k,l + read_wf = .True. + TOUCH read_wf + + double precision, parameter :: thr = 1.d-15 + + double precision :: accu,twodm + accu = 0.d0 + do i=1,mo_num + do j=1,mo_num + do k=1,mo_num + do l=1,mo_num + twodm = coussin_peter_two_rdm_mo(i,j,k,l,1) + if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then + print*,'' + print*,'sum' + write(*,'(3X,4(I2,X),3(F16.13,X))'), i, j, k, l, twodm,P0tuvx(i,j,k,l),dabs(twodm - P0tuvx(i,j,k,l)) + print*,'' + endif + accu += dabs(twodm - P0tuvx(i,j,k,l)) + enddo + enddo + enddo + enddo + print*,'accu = ',accu + print*,' ',accu / dble(mo_num**4) + +end 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/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..1318bb43 --- /dev/null +++ b/src/two_body_rdm/README.rst @@ -0,0 +1,6 @@ +============ +two_body_rdm +============ + +Contains the two rdms (aa,bb,ab) stored as plain arrays + 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..195f439a --- /dev/null +++ b/src/two_body_rdm/ab_only_routines.irp.f @@ -0,0 +1,402 @@ + + subroutine two_rdm_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_rdm_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_rdm_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_rdm_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call two_rdm_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call two_rdm_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call two_rdm_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call two_rdm_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_rdm_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_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..6536e382 --- /dev/null +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -0,0 +1,443 @@ + + subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) + 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_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_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + 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_openmp_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_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select + end + +BEGIN_TEMPLATE + +subroutine all_two_rdm_dm_nstates_openmp_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + 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_alpha_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/routines_compute_2rdm.irp.f b/src/two_body_rdm/routines_compute_2rdm.irp.f new file mode 100644 index 00000000..7165576f --- /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 + 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 + 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 + 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 + 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 + 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 + 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 + 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/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f new file mode 100644 index 00000000..1c299bba --- /dev/null +++ b/src/two_body_rdm/two_rdm.irp.f @@ -0,0 +1,84 @@ + + BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF + END_DOC + integer :: i,j,k,l + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + coussin_peter_two_rdm_mo(i,j,k,l,:) = 0.5d0 * (two_rdm_alpha_beta_mo(i,j,k,l,:) + two_rdm_alpha_beta_mo(i,j,k,l,:)) & + + two_rdm_alpha_alpha_mo(i,j,k,l,:) & + + two_rdm_beta_beta_mo(i,j,k,l,:) + enddo + enddo + enddo + enddo + + END_PROVIDER + + + 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_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call 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 + From 3e38912dcb484c2e396e182c47080ce561748445 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 21:41:17 +0200 Subject: [PATCH 17/28] indentation --- src/casscf/test_two_rdm.irp.f | 10 +- src/two_body_rdm/README.rst | 4 +- src/two_body_rdm/all_2rdm_routines.irp.f | 877 +++++++++++------------ src/two_body_rdm/two_rdm.irp.f | 138 ++-- 4 files changed, 516 insertions(+), 513 deletions(-) diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f index 562d15a6..f2afdb25 100644 --- a/src/casscf/test_two_rdm.irp.f +++ b/src/casscf/test_two_rdm.irp.f @@ -8,11 +8,11 @@ program print_two_rdm double precision :: accu,twodm accu = 0.d0 - do i=1,mo_num - do j=1,mo_num - do k=1,mo_num - do l=1,mo_num - twodm = coussin_peter_two_rdm_mo(i,j,k,l,1) + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + twodm = coussin_peter_two_rdm_mo(list_act(i),list_act(j),list_act(k),list_act(l),1) if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then print*,'' print*,'sum' diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst index 1318bb43..ea5839e8 100644 --- a/src/two_body_rdm/README.rst +++ b/src/two_body_rdm/README.rst @@ -2,5 +2,7 @@ two_body_rdm ============ -Contains the two rdms (aa,bb,ab) stored as plain arrays +Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as +maps, with pysicists notation, consistent with the two-electron integrals in the +MO basis. diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f index 6536e382..75d71ded 100644 --- a/src/two_body_rdm/all_2rdm_routines.irp.f +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -1,443 +1,442 @@ - - subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) - 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_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_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) - 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_openmp_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_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (2) - call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (3) - call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (4) - call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case default - call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - end select - end - -BEGIN_TEMPLATE - +subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) + 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_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_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + 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_openmp_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_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + BEGIN_TEMPLATE + subroutine all_two_rdm_dm_nstates_openmp_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - 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 + 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 - 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_alpha_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 - + 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_alpha_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 - + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f index 1c299bba..bed6f88d 100644 --- a/src/two_body_rdm/two_rdm.irp.f +++ b/src/two_body_rdm/two_rdm.irp.f @@ -1,84 +1,86 @@ - - BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] - implicit none - BEGIN_DOC - ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF - END_DOC - integer :: i,j,k,l - do l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num - coussin_peter_two_rdm_mo(i,j,k,l,:) = 0.5d0 * (two_rdm_alpha_beta_mo(i,j,k,l,:) + two_rdm_alpha_beta_mo(i,j,k,l,:)) & - + two_rdm_alpha_alpha_mo(i,j,k,l,:) & - + two_rdm_beta_beta_mo(i,j,k,l,:) +BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF + END_DOC + integer :: i,j,k,l, istate + do istate = 1,N_states + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + coussin_peter_two_rdm_mo (i,j,k,l,istate) = & + two_rdm_alpha_beta_mo (i,j,k,l,istate) + & + two_rdm_alpha_alpha_mo(i,j,k,l,istate) + & + two_rdm_beta_beta_mo (i,j,k,l,istate) + enddo + enddo + enddo enddo - enddo enddo - enddo - END_PROVIDER +END_PROVIDER 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_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) - call wall_time(cpu_1) - print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) - - END_PROVIDER + 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_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call 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 + 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 enddo - enddo - call wall_time(cpu_1) - print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) - - END_PROVIDER + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + +END_PROVIDER From 92e44f53bae20a9995f968c16017ca402c7c5962 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 23:06:35 +0200 Subject: [PATCH 18/28] Fixed small bugs --- src/casscf/casscf.irp.f | 5 +++-- src/casscf/neworbs.irp.f | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 10a3e34a..8aaa1925 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -3,8 +3,8 @@ program casscf BEGIN_DOC ! TODO : Put the documentation of the program here END_DOC - no_vvvv_integrals = .True. - SOFT_TOUCH no_vvvv_integrals +! no_vvvv_integrals = .True. +! SOFT_TOUCH no_vvvv_integrals call run end @@ -13,6 +13,7 @@ subroutine run double precision :: energy_old, energy logical :: converged integer :: iteration + PROVIDE mo_two_e_integrals_in_map converged = .False. energy = 0.d0 diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index fd94eb6a..f4319485 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -25,7 +25,7 @@ BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] end do if (bavard) then - do i=2,nMonoEx+1 + do i=2,nMonoEx write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) end do end if @@ -77,14 +77,14 @@ END_PROVIDER 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 - c0=SXeigenvec(1,best_vector) - do i=1,nMonoEx+1 SXvector(i)=SXeigenvec(i,best_vector)/c0 end do From 82bbf95fead74f927ba1c15779b958623dcfc3ef Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 23:46:30 +0200 Subject: [PATCH 19/28] Fixed small bugs --- src/bitmask/core_inact_act_virt.irp.f | 4 ++++ src/casscf/casscf.irp.f | 9 ++++----- src/cipsi/pt2_stoch_routines.irp.f | 13 +++++++++++-- src/generators_cas/generators.irp.f | 1 + 4 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index f830da4e..177c3df5 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -141,6 +141,10 @@ END_PROVIDER n_act_orb_tmp = 0 n_virt_orb_tmp = 0 n_del_orb_tmp = 0 + core_bitmask = 0_bit_kind + inact_bitmask = 0_bit_kind + act_bitmask = 0_bit_kind + virt_bitmask = 0_bit_kind do i = 1, mo_num if(mo_class(i) == 'Core')then n_core_orb_tmp += 1 diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 8aaa1925..54bf35ee 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -3,8 +3,8 @@ program casscf BEGIN_DOC ! TODO : Put the documentation of the program here END_DOC -! no_vvvv_integrals = .True. -! SOFT_TOUCH no_vvvv_integrals + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals call run end @@ -13,15 +13,13 @@ subroutine run double precision :: energy_old, energy logical :: converged integer :: iteration - PROVIDE mo_two_e_integrals_in_map converged = .False. energy = 0.d0 mo_label = "MCSCF" iteration = 1 do while (.not.converged) - call run_cipsi - + call run_stochastic_cipsi energy_old = energy energy = eone+etwo+ecore @@ -39,6 +37,7 @@ subroutine run iteration += 1 FREE mo_integrals_map mo_two_e_integrals_in_map psi_det psi_coef SOFT_TOUCH mo_coef N_det + enddo 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/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, :) From ae3a4929b6443f13512e2c1b28642812914bc84a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 23:59:21 +0200 Subject: [PATCH 20/28] Using fast 2RDM s --- src/casscf/densities.irp.f | 146 ++++++--------------------------- src/casscf/test_two_rdm.irp.f | 10 +-- src/two_body_rdm/two_rdm.irp.f | 30 ++++--- 3 files changed, 46 insertions(+), 140 deletions(-) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 9b8dba78..7b243bb4 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -29,7 +29,9 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] ! END_DOC implicit none - integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + 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 @@ -43,125 +45,25 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] write(6,*) ' providing density matrix P0' endif - P0tuvx = 0.d0 - - ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do t=1,n_act_orb - ipart=list_act(t) - do u=1,n_act_orb - ihole=list_act(u) - ! apply E_tu - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) - ! det_mu_ex1 is in the list - if (nu1.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 - ! and we fill P0_tvvu - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do - end do - end if - ! det_mu_ex2 is in the list - if (nu2.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do - end do - end if - end do - end do - end do - ! now we do the double excitation E_tu E_vx |0> - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do v=1,n_act_orb - ipart=list_act(v) - do x=1,n_act_orb - ihole=list_act(x) - ! apply E_vx - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) - ! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> - if (ierr1.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex1,det_mu_ex11,N_int) - call det_copy(det_mu_ex1,det_mu_ex12,N_int) - call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11& - ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) - if (nu11.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate)& - *phase11*phase1 - end do - end if - if (nu12.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate)& - *phase12*phase1 - end do - end if - end do - end do - end if - - ! we apply E_tu to the second resultant determinant - if (ierr2.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex2,det_mu_ex21,N_int) - call det_copy(det_mu_ex2,det_mu_ex22,N_int) - call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21& - ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) - if (nu21.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate)& - *phase21*phase2 - end do - end if - if (nu22.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate)& - *phase22*phase2 - end do - end if - end do - end do - end if - - end do - end do - end do - - ! we average by just dividing by the number of states - do x=1,n_act_orb - do v=1,n_act_orb - do u=1,n_act_orb - do t=1,n_act_orb - P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) - end do - end do - end do - end do - + 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_average_weight(istate) * & + ( two_rdm_alpha_beta_mo (tt,uu,vv,xx,istate) + & + two_rdm_alpha_alpha_mo(tt,uu,vv,xx,istate) + & + two_rdm_beta_beta_mo (tt,uu,vv,xx,istate) ) + enddo + enddo + enddo + enddo + enddo + END_PROVIDER diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f index 562d15a6..9abe0aa0 100644 --- a/src/casscf/test_two_rdm.irp.f +++ b/src/casscf/test_two_rdm.irp.f @@ -8,11 +8,11 @@ program print_two_rdm double precision :: accu,twodm accu = 0.d0 - do i=1,mo_num - do j=1,mo_num - do k=1,mo_num - do l=1,mo_num - twodm = coussin_peter_two_rdm_mo(i,j,k,l,1) + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + twodm = coussin_peter_two_rdm_mo(list_act(i),list_act(j),list_act(k),list_act(l)) if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then print*,'' print*,'sum' diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f index 1c299bba..a75a92cc 100644 --- a/src/two_body_rdm/two_rdm.irp.f +++ b/src/two_body_rdm/two_rdm.irp.f @@ -1,23 +1,27 @@ - - BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num)] implicit none BEGIN_DOC ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF END_DOC - integer :: i,j,k,l - do l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num - coussin_peter_two_rdm_mo(i,j,k,l,:) = 0.5d0 * (two_rdm_alpha_beta_mo(i,j,k,l,:) + two_rdm_alpha_beta_mo(i,j,k,l,:)) & - + two_rdm_alpha_alpha_mo(i,j,k,l,:) & - + two_rdm_beta_beta_mo(i,j,k,l,:) - enddo - enddo + integer :: i,j,k,l, istate + coussin_peter_two_rdm_mo = 0.d0 + do istate=1,N_states + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + coussin_peter_two_rdm_mo(i,j,k,l) = & + state_average_weight(istate) * & + ( two_rdm_alpha_beta_mo(i,j,k,l,istate) + & + two_rdm_alpha_alpha_mo(i,j,k,l,istate)+ & + two_rdm_beta_beta_mo(i,j,k,l,istate) ) + enddo + enddo + enddo enddo enddo - END_PROVIDER +END_PROVIDER BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] From a4d2e39978ecb4802fee53b80e9d525e8e010900 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Jun 2019 00:04:12 +0200 Subject: [PATCH 21/28] Minor fix --- src/cipsi/cipsi.irp.f | 1 + src/cipsi/stochastic_cipsi.irp.f | 1 + 2 files changed, 2 insertions(+) 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/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 From d742bdd655a28648652dc9ba45ea96248a32ce11 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Jun 2019 00:06:51 +0200 Subject: [PATCH 22/28] Cleaning --- src/casscf/test_two_rdm.irp.f | 30 ------------------------------ src/two_body_rdm/two_rdm.irp.f | 26 -------------------------- 2 files changed, 56 deletions(-) delete mode 100644 src/casscf/test_two_rdm.irp.f diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f deleted file mode 100644 index 9abe0aa0..00000000 --- a/src/casscf/test_two_rdm.irp.f +++ /dev/null @@ -1,30 +0,0 @@ -program print_two_rdm - implicit none - integer :: i,j,k,l - read_wf = .True. - TOUCH read_wf - - double precision, parameter :: thr = 1.d-15 - - double precision :: accu,twodm - accu = 0.d0 - do i=1,n_act_orb - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - twodm = coussin_peter_two_rdm_mo(list_act(i),list_act(j),list_act(k),list_act(l)) - if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then - print*,'' - print*,'sum' - write(*,'(3X,4(I2,X),3(F16.13,X))'), i, j, k, l, twodm,P0tuvx(i,j,k,l),dabs(twodm - P0tuvx(i,j,k,l)) - print*,'' - endif - accu += dabs(twodm - P0tuvx(i,j,k,l)) - enddo - enddo - enddo - enddo - print*,'accu = ',accu - print*,' ',accu / dble(mo_num**4) - -end diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f index a75a92cc..89eecdcc 100644 --- a/src/two_body_rdm/two_rdm.irp.f +++ b/src/two_body_rdm/two_rdm.irp.f @@ -1,29 +1,3 @@ -BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num)] - implicit none - BEGIN_DOC - ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF - END_DOC - integer :: i,j,k,l, istate - coussin_peter_two_rdm_mo = 0.d0 - do istate=1,N_states - do l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num - coussin_peter_two_rdm_mo(i,j,k,l) = & - state_average_weight(istate) * & - ( two_rdm_alpha_beta_mo(i,j,k,l,istate) + & - two_rdm_alpha_alpha_mo(i,j,k,l,istate)+ & - two_rdm_beta_beta_mo(i,j,k,l,istate) ) - enddo - enddo - enddo - enddo - enddo - -END_PROVIDER - - 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)] From e9724fa8c74662b4d39335e6c4b185f7d04bbaf4 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 28 Jun 2019 15:17:04 +0200 Subject: [PATCH 23/28] beginning to work on general routine for 2rdm --- src/two_body_rdm/general_2rdm_routines.irp.f | 488 ++++++++++++++++++ src/two_body_rdm/orb_range_2_rdm.irp.f | 61 +++ .../routines_compute_2rdm_orb_range.irp.f | 430 +++++++++++++++ 3 files changed, 979 insertions(+) create mode 100644 src/two_body_rdm/general_2rdm_routines.irp.f create mode 100644 src/two_body_rdm/orb_range_2_rdm.irp.f create mode 100644 src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f diff --git a/src/two_body_rdm/general_2rdm_routines.irp.f b/src/two_body_rdm/general_2rdm_routines.irp.f new file mode 100644 index 00000000..a9fcd61a --- /dev/null +++ b/src/two_body_rdm/general_2rdm_routines.irp.f @@ -0,0 +1,488 @@ +subroutine orb_range_two_rdm_dm_nstates_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_dm_nstates_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_dm_nstates_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) + + + PROVIDE N_int + + select case (N_int) + case (1) + call orb_range_two_rdm_dm_nstates_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_dm_nstates_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_dm_nstates_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_dm_nstates_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_dm_nstates_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_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the two rdm for the N_st vectors |u_t> + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb + ! In any cases, the state average weights will be used with an array state_weights + ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + double precision :: c_average + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + 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_openmp_work' + print*,'ispin = ',ispin + stop + endif + + + 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,norb,list_orb,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,norb,list_orb,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,norb,list_orb,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,norb,list_orb,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,norb,list_orb,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,norb,list_orb,ispin) + endif + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + if(beta_beta.or.spin_trace)then + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,norb,list_orb,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,norb,list_orb,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..621f6c4b --- /dev/null +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -0,0 +1,61 @@ + + + + BEGIN_PROVIDER [double precision, 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(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 1 + act_two_rdm_alpha_alpha_mo = 0.D0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_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, 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(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 2 + act_two_rdm_beta_beta_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_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, 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(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'providint act_two_rdm_alpha_beta_mo ' + ispin = 3 + print*,'ispin = ',ispin + act_two_rdm_alpha_beta_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_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, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + 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 + act_two_rdm_spin_trace_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + 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..d115f1bd --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -0,0 +1,430 @@ + + subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,norb,list_orb) + 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,norb,list_orb(norb) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1 + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + 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,h1,h2,h2) += c_1 + enddo + enddo + end + + + subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of ALL THREE two body rdm + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + 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, occ, n_occ_ab, N_int) + if(alpha_beta)then + 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) += c_1 + enddo + enddo + else if (alpha_alpha)then + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array(h1,h1,h2,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) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,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) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2) += 0.5d0 * (c_1 ) + big_array(h2,h2,h1,h1) += 0.5d0 * (c_1 ) + enddo + enddo + ! alpha alpha + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + ! beta beta + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,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,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),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) + double precision, intent(in) :: c_1 + 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 + 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) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + if(alpha_beta)then + big_array(h1,p1,h2,p2) += c_1 * phase + else if(spin_trace)then + big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase + big_array(h2,p2,h1,p1) += 0.5d0 * c_1 * phase + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),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) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + 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) + p1 = exc(1,2,1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2) += c_1 * phase + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,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) + p1 = exc(1,2,1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h2,h2,h1,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,norb,list_orb,ispin) + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS + END_DOC + use bitmasks + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),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) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + 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) + p1 = exc(1,2,1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h2,p1,h1,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,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),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) + double precision, intent(in) :: c_1 + + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + 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) + 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) += 0.5d0 * c_1 * phase + big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h2,p1,h1,h2) -= 0.5d0 * c_1 * phase + enddo + enddo + endif + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1 + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + 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) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) + if(alpha_alpha.or.spin_trace)then + do istate = 1, N_states + big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase + big_array(h1,p2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,p2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h2,p1,h1,p2) -= 0.5d0 * c_1 * phase + enddo + endif + end + + subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + 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,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1 + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + 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) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) + if(beta_beta.or.spin_trace)then + big_array(h1,p1,h2,p2) += 0.5d0 * c_1* phase + big_array(h1,p2,h2,p1) -= 0.5d0 * c_1* phase + + big_array(h2,p2,h1,p1) += 0.5d0 * c_1* phase + big_array(h2,p1,h1,p2) -= 0.5d0 * c_1* phase + endif + end + From c90c49b56c100b367067d90edbf226dd784a8cc8 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 28 Jun 2019 15:55:32 +0200 Subject: [PATCH 24/28] beginning to do it directly in physicist --- .../routines_compute_2rdm_orb_range.irp.f | 64 +++++++++---------- 1 file changed, 31 insertions(+), 33 deletions(-) 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 index d115f1bd..d918932a 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -18,7 +18,7 @@ h1 = occ(i,1) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += c_1 + big_array(h1,h2,h1,h2) += c_1 enddo enddo end @@ -61,7 +61,7 @@ h1 = occ(i,1) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += c_1 + big_array(h1,h2,h1,h2) += c_1 enddo enddo else if (alpha_alpha)then @@ -69,7 +69,7 @@ h1 = occ(i,1) do j = 1, n_occ_ab(1) h2 = occ(j,1) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo @@ -78,7 +78,7 @@ h1 = occ(i,2) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo @@ -88,25 +88,23 @@ h1 = occ(i,1) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += 0.5d0 * (c_1 ) - big_array(h2,h2,h1,h1) += 0.5d0 * (c_1 ) + big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 ) + big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 ) enddo enddo - ! alpha alpha do i = 1, n_occ_ab(1) h1 = occ(i,1) do j = 1, n_occ_ab(1) h2 = occ(j,1) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo - ! beta beta do i = 1, n_occ_ab(2) h1 = occ(i,2) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo @@ -147,10 +145,10 @@ p1 = exc(1,2,1) p2 = exc(1,2,2) if(alpha_beta)then - big_array(h1,p1,h2,p2) += c_1 * phase + big_array(h1,h2,p1,p2) += c_1 * phase else if(spin_trace)then - big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase - big_array(h2,p2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase + big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase endif end @@ -195,7 +193,7 @@ p1 = exc(1,2,1) do i = 1, n_occ_ab(2) h2 = occ(i,2) - big_array(h1,p1,h2,h2) += c_1 * phase + big_array(h1,h2,p1,h2) += c_1 * phase enddo else ! Mono beta @@ -203,7 +201,7 @@ p1 = exc(1,2,2) do i = 1, n_occ_ab(1) h2 = occ(i,1) - big_array(h2,h2,h1,p1) += c_1 * phase + big_array(h2,h1,h2,p1) += c_1 * phase enddo endif else if(spin_trace)then @@ -213,8 +211,8 @@ p1 = exc(1,2,1) do i = 1, n_occ_ab(2) h2 = occ(i,2) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase - big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + 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 @@ -222,8 +220,8 @@ p1 = exc(1,2,2) do i = 1, n_occ_ab(1) h2 = occ(i,1) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase - big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + 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 @@ -270,11 +268,11 @@ p1 = exc(1,2,1) do i = 1, n_occ_ab(1) h2 = occ(i,1) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + 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,h2,h1,p1) += 0.5d0 * c_1 * phase - big_array(h2,p1,h1,h2) -= 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 @@ -327,11 +325,11 @@ do istate = 1, N_states do i = 1, n_occ_ab(2) h2 = occ(i,2) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + 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,h2,h1,p1) += 0.5d0 * c_1 * phase - big_array(h2,p1,h1,h2) -= 0.5d0 * c_1 * phase + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase enddo enddo endif @@ -375,11 +373,11 @@ p2 =exc(2,2) if(alpha_alpha.or.spin_trace)then do istate = 1, N_states - big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase - big_array(h1,p2,h2,p1) -= 0.5d0 * c_1 * phase + 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,p2,h1,p1) += 0.5d0 * c_1 * phase - big_array(h2,p1,h1,p2) -= 0.5d0 * c_1 * phase + big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase enddo endif end @@ -420,11 +418,11 @@ p1 =exc(1,2) p2 =exc(2,2) if(beta_beta.or.spin_trace)then - big_array(h1,p1,h2,p2) += 0.5d0 * c_1* phase - big_array(h1,p2,h2,p1) -= 0.5d0 * c_1* phase + 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,p2,h1,p1) += 0.5d0 * c_1* phase - big_array(h2,p1,h1,p2) -= 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 From de7e1f70950bebaa8315aa2c12046ef4814a4478 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 28 Jun 2019 16:51:16 +0200 Subject: [PATCH 25/28] added test for energy --- src/casscf/get_energy.irp.f | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 src/casscf/get_energy.irp.f diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f new file mode 100644 index 00000000..a7b53f13 --- /dev/null +++ b/src/casscf/get_energy.irp.f @@ -0,0 +1,21 @@ +program print_2rdm + implicit none + read_wf = .True. + touch read_wf + integer :: i,j,k,l + double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral + thr = 1.d-10 + + accu = 0.d0 + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + integral = get_two_e_integral(i,j,k,l,mo_integrals_map) + accu(1) += act_two_rdm_spin_trace_mo(i,j,k,l) * integral + enddo + enddo + enddo + enddo + print*,'accu = ',accu(1) +end From 78fe995f55360da3130ed1a1cba9ac0793e0276a Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 28 Jun 2019 20:45:07 +0200 Subject: [PATCH 26/28] getting there with active orbitals --- src/bitmask/bitmasks_routines.irp.f | 33 ++- src/casscf/get_energy.irp.f | 31 ++- src/two_body_rdm/general_2rdm_routines.irp.f | 42 ++-- src/two_body_rdm/orb_range_2_rdm.irp.f | 10 +- .../routines_compute_2rdm_orb_range.irp.f | 189 +++++++++++++++--- 5 files changed, 248 insertions(+), 57 deletions(-) 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/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index a7b53f13..29a12cad 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -2,20 +2,39 @@ program print_2rdm implicit none read_wf = .True. touch read_wf + 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 l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num + 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) += act_two_rdm_spin_trace_mo(i,j,k,l) * integral + accu(1) += act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral + !if(dabs(act_two_rdm_spin_trace_mo(ii,jj,kk,ll)).gt.thr)then + !print*,'',ii,jj,kk,ll,act_two_rdm_spin_trace_mo(ii,jj,kk,ll)*integral + !print*,'accu',accu(1) + !endif enddo enddo enddo enddo - print*,'accu = ',accu(1) + print*,'accu = ',accu(1) + print*,'psi_energy_two_e = ',psi_energy_two_e +!double precision :: hij +!call i_H_j_double_alpha_beta(psi_det(1,1,1),psi_det(1,1,2),N_int,hij) +!print*,'hij * 2',hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 +!print*,'psi diag = ',psi_energy_two_e - hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 end diff --git a/src/two_body_rdm/general_2rdm_routines.irp.f b/src/two_body_rdm/general_2rdm_routines.irp.f index a9fcd61a..0157c46b 100644 --- a/src/two_body_rdm/general_2rdm_routines.irp.f +++ b/src/two_body_rdm/general_2rdm_routines.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze) +subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -13,6 +13,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,stat 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) @@ -30,7 +31,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,stat size(u_t, 1), & N_det, N_st) - call orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_two_rdm_dm_nstates_openmp_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 @@ -39,7 +40,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,stat end -subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_dm_nstates_openmp_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 @@ -49,23 +50,25 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb 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_dm_nstates_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_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_dm_nstates_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_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_dm_nstates_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_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_dm_nstates_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_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_dm_nstates_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) end select end @@ -73,7 +76,7 @@ end BEGIN_TEMPLATE -subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -89,6 +92,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l 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 @@ -112,6 +116,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l 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. @@ -129,7 +134,10 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l 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)) @@ -242,7 +250,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l 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,norb,list_orb,ispin) + 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 @@ -319,9 +327,9 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,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,norb,list_orb,ispin) + 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,norb,list_orb,ispin) + 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 @@ -344,7 +352,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l 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,norb,list_orb,ispin) + 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 @@ -411,9 +419,9 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,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,norb,list_orb,ispin) + 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,norb,list_orb,ispin) + 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 @@ -435,7 +443,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ASSERT (l_a <= N_det) enddo @@ -467,7 +475,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l 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,norb,list_orb,ispin) + 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 diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f index 621f6c4b..e98612c5 100644 --- a/src/two_body_rdm/orb_range_2_rdm.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -10,7 +10,7 @@ ! condition for alpha/beta spin ispin = 1 act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_dm_nstates_openmp(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 @@ -23,7 +23,7 @@ ! condition for alpha/beta spin ispin = 2 act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_dm_nstates_openmp(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 @@ -41,7 +41,7 @@ ispin = 3 print*,'ispin = ',ispin act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_dm_nstates_openmp(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 @@ -55,7 +55,9 @@ ! condition for alpha/beta spin ispin = 4 act_two_rdm_spin_trace_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + integer :: i + + call orb_range_two_rdm_dm_nstates_openmp(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)) END_PROVIDER 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 index d918932a..c2283fb2 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -1,14 +1,15 @@ - subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,norb,list_orb) + 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,norb,list_orb(norb) + 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) @@ -24,21 +25,32 @@ end - subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,norb,list_orb,ispin) + 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 ALL THREE two body rdm END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + 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,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 + +!print*,'ahah' +!call debug_det(det_1_act,N_int) +!pause alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -55,29 +67,43 @@ 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) + 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) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,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) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(1) - h2 = occ(j,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) - h1 = occ(i,2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,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 @@ -85,25 +111,38 @@ else if(spin_trace)then ! 0.5 * (alpha beta + beta alpha) do i = 1, n_occ_ab(1) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,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) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(1) - h2 = occ(j,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) - h1 = occ(i,2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,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 @@ -112,20 +151,23 @@ end - subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + 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 alpha/beta 2RDM only for DOUBLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + 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,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. @@ -139,28 +181,52 @@ 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,norb,list_orb,ispin) + 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 alpha/beta 2RDM only for SINGLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + 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) @@ -170,6 +236,7 @@ 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. @@ -190,17 +257,29 @@ 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 @@ -208,18 +287,30 @@ 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 @@ -227,15 +318,17 @@ endif end - subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + 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 alpha/alpha 2RDM only for SINGLE EXCITATIONS END_DOC use bitmasks implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + 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) @@ -245,6 +338,7 @@ 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. @@ -265,9 +359,15 @@ 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 @@ -280,15 +380,17 @@ endif end - subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + 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 beta /beta 2RDM only for SINGLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + 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 @@ -298,6 +400,7 @@ 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. @@ -321,10 +424,16 @@ else ! Mono beta h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) do istate = 1, N_states do i = 1, n_occ_ab(2) h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase @@ -337,15 +446,17 @@ end - subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + 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 alpha/alpha 2RDM only for DOUBLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 integer :: i,j,h1,h2,p1,p2,istate @@ -353,6 +464,7 @@ 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. @@ -368,9 +480,17 @@ endif call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) h1 =exc(1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) h2 =exc(2,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) p1 =exc(1,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) p2 =exc(2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) if(alpha_alpha.or.spin_trace)then do istate = 1, N_states big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase @@ -382,22 +502,25 @@ endif end - subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + 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 beta /beta 2RDM only for DOUBLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 integer :: i,j,h1,h2,p1,p2,istate integer :: exc(0:2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -414,9 +537,17 @@ 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 From 57eabff6758b254d9c6e92b04e356205509ecc1d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 29 Jun 2019 17:29:32 +0200 Subject: [PATCH 27/28] added documentation for the two-rdm --- src/casscf/densities.irp.f | 8 +- src/casscf/get_energy.irp.f | 14 +- src/two_body_rdm/ab_only_routines.irp.f | 22 +-- src/two_body_rdm/all_2rdm_routines.irp.f | 2 +- src/two_body_rdm/orb_range_2_rdm.irp.f | 20 +++ ...outines.irp.f => orb_range_routines.irp.f} | 0 src/two_body_rdm/routines_compute_2rdm.irp.f | 14 +- .../routines_compute_2rdm_orb_range.irp.f | 129 +++++++++++++++++- 8 files changed, 168 insertions(+), 41 deletions(-) rename src/two_body_rdm/{general_2rdm_routines.irp.f => orb_range_routines.irp.f} (100%) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 7b243bb4..30a914f1 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -42,7 +42,7 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22 if (bavard) then - write(6,*) ' providing density matrix P0' + write(6,*) ' providing the 2 body RDM on the active part' endif P0tuvx= 0.d0 @@ -55,11 +55,7 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] uu = list_act(u) do t = 1, n_act_orb tt = list_act(t) - P0tuvx(t,u,v,x) = & - state_average_weight(istate) * & - ( two_rdm_alpha_beta_mo (tt,uu,vv,xx,istate) + & - two_rdm_alpha_alpha_mo(tt,uu,vv,xx,istate) + & - two_rdm_beta_beta_mo (tt,uu,vv,xx,istate) ) + P0tuvx(t,u,v,x) = act_two_rdm_spin_trace_mo(t,v,u,x) enddo enddo enddo diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index 29a12cad..0a5cfb49 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -1,5 +1,10 @@ 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 read_wf = .True. touch read_wf call routine @@ -23,18 +28,9 @@ subroutine routine i = list_act(ii) integral = get_two_e_integral(i,j,k,l,mo_integrals_map) accu(1) += act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral - !if(dabs(act_two_rdm_spin_trace_mo(ii,jj,kk,ll)).gt.thr)then - !print*,'',ii,jj,kk,ll,act_two_rdm_spin_trace_mo(ii,jj,kk,ll)*integral - !print*,'accu',accu(1) - !endif enddo enddo enddo enddo print*,'accu = ',accu(1) - print*,'psi_energy_two_e = ',psi_energy_two_e -!double precision :: hij -!call i_H_j_double_alpha_beta(psi_det(1,1,1),psi_det(1,1,2),N_int,hij) -!print*,'hij * 2',hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 -!print*,'psi diag = ',psi_energy_two_e - hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 end diff --git a/src/two_body_rdm/ab_only_routines.irp.f b/src/two_body_rdm/ab_only_routines.irp.f index 195f439a..9041c753 100644 --- a/src/two_body_rdm/ab_only_routines.irp.f +++ b/src/two_body_rdm/ab_only_routines.irp.f @@ -1,9 +1,9 @@ - subroutine two_rdm_dm_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + subroutine two_rdm_ab_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> + ! Computes the alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS ! ! Assumes that the determinants are in psi_det ! @@ -27,7 +27,7 @@ size(u_t, 1), & N_det, N_st) - call two_rdm_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + call two_rdm_ab_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 @@ -37,11 +37,11 @@ end - subroutine two_rdm_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + subroutine two_rdm_ab_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> + ! Computes the alpha/beta part of the two-body density matrix ! ! Default should be 1,N_det,0,1 END_DOC @@ -55,20 +55,20 @@ select case (N_int) case (1) - call two_rdm_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call two_rdm_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call two_rdm_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call two_rdm_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case default - call two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_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_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + subroutine two_rdm_ab_nstates_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 diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f index 75d71ded..3f08b18f 100644 --- a/src/two_body_rdm/all_2rdm_routines.irp.f +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -2,7 +2,7 @@ subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab, use bitmasks implicit none BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! 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 ! diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f index e98612c5..c40c46d2 100644 --- a/src/two_body_rdm/orb_range_2_rdm.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -4,6 +4,10 @@ BEGIN_PROVIDER [double precision, 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 +! 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 @@ -17,6 +21,10 @@ BEGIN_PROVIDER [double precision, 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 +! 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 @@ -30,6 +38,10 @@ BEGIN_PROVIDER [double precision, 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 +! 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 @@ -48,6 +60,14 @@ BEGIN_PROVIDER [double precision, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none + BEGIN_DOC +! 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} 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) diff --git a/src/two_body_rdm/general_2rdm_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f similarity index 100% rename from src/two_body_rdm/general_2rdm_routines.irp.f rename to src/two_body_rdm/orb_range_routines.irp.f diff --git a/src/two_body_rdm/routines_compute_2rdm.irp.f b/src/two_body_rdm/routines_compute_2rdm.irp.f index 7165576f..112d2e36 100644 --- a/src/two_body_rdm/routines_compute_2rdm.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm.irp.f @@ -3,7 +3,7 @@ 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 +! 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 @@ -31,7 +31,7 @@ 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 +! 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 @@ -77,7 +77,7 @@ 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 +! 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 @@ -101,7 +101,7 @@ 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 +! 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 @@ -140,7 +140,7 @@ 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 +! 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 @@ -177,7 +177,7 @@ 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 +! 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 @@ -214,7 +214,7 @@ 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 +! 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 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 index c2283fb2..a3c7a76d 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -28,7 +28,20 @@ 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 ALL THREE two body rdm +! 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 @@ -154,7 +167,24 @@ 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 alpha/beta 2RDM only for DOUBLE EXCITATIONS +! 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 @@ -219,7 +249,24 @@ 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 alpha/beta 2RDM only for SINGLE EXCITATIONS +! 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 @@ -320,7 +367,24 @@ 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 alpha/alpha 2RDM only for SINGLE EXCITATIONS +! 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 @@ -383,7 +447,24 @@ 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 beta /beta 2RDM only for SINGLE EXCITATIONS +! 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 @@ -449,7 +530,24 @@ 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 alpha/alpha 2RDM only for DOUBLE EXCITATIONS +! 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 @@ -505,7 +603,24 @@ 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 beta /beta 2RDM only for DOUBLE EXCITATIONS +! 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 From 3c9728be99bc54ec98c217936e03861e8652a7c5 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 29 Jun 2019 17:34:20 +0200 Subject: [PATCH 28/28] comments --- src/casscf/densities.irp.f | 7 ++++--- src/two_body_rdm/README.rst | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 30a914f1..3cfd7583 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -19,14 +19,15 @@ 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 - ! matrices are state averaged + ! 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 + ! 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 diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst index ea5839e8..978240c9 100644 --- a/src/two_body_rdm/README.rst +++ b/src/two_body_rdm/README.rst @@ -3,6 +3,6 @@ two_body_rdm ============ Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as -maps, with pysicists notation, consistent with the two-electron integrals in the +arrays, with pysicists notation, consistent with the two-electron integrals in the MO basis.