diff --git a/src/tc_bi_ortho/print_tc_dump.irp.f b/src/tc_bi_ortho/print_tc_dump.irp.f index 327e0f02..55df20a2 100644 --- a/src/tc_bi_ortho/print_tc_dump.irp.f +++ b/src/tc_bi_ortho/print_tc_dump.irp.f @@ -10,7 +10,10 @@ program tc_bi_ortho my_n_pt_a_grid = 50 touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call ERI_dump() call KMat_tilde_dump() + call LMat_tilde_dump() + end ! --- @@ -18,7 +21,7 @@ end subroutine KMat_tilde_dump() implicit none - integer :: i, j, k, l + integer :: i, j, k, l PROVIDE mo_bi_ortho_tc_two_e_chemist @@ -42,3 +45,91 @@ subroutine KMat_tilde_dump() end subroutine KMat_tilde_dump ! --- + +subroutine ERI_dump() + + implicit none + integer :: i, j, k, l + double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:) + + PROVIDE mo_r_coef mo_l_coef + + allocate(a2(ao_num,ao_num,ao_num,mo_num)) + + call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0 & + , ao_two_e_coul(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num & + , 0.d0 , a2(1,1,1,1), ao_num*ao_num*ao_num) + + allocate(a1(ao_num,ao_num,mo_num,mo_num)) + + call dgemm( 'T', 'N', ao_num*ao_num*mo_num, mo_num, ao_num, 1.d0 & + , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num & + , 0.d0, a1(1,1,1,1), ao_num*ao_num*mo_num) + + deallocate(a2) + allocate(a2(ao_num,mo_num,mo_num,mo_num)) + + call dgemm( 'T', 'N', ao_num*mo_num*mo_num, mo_num, ao_num, 1.d0 & + , a1(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num & + , 0.d0, a2(1,1,1,1), ao_num*mo_num*mo_num) + + deallocate(a1) + allocate(a1(mo_num,mo_num,mo_num,mo_num)) + + call dgemm( 'T', 'N', mo_num*mo_num*mo_num, mo_num, ao_num, 1.d0 & + , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num & + , 0.d0, a1(1,1,1,1), mo_num*mo_num*mo_num) + + deallocate(a2) + + open(33, file='ERI.dat', action='write') + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + write(33, '(4(I4, 2X), 4X, E15.7)') i, j, k, l, a1(i,j,k,l) + enddo + enddo + enddo + enddo + close(33) + + deallocate(a1) + + return +end subroutine ERI_dump + +! --- + +subroutine LMat_tilde_dump() + + implicit none + integer :: i, j, k, l, m, n + double precision :: integral + + PROVIDE mo_bi_ortho_tc_two_e_chemist + + print *, ' Lmat_tilde in phys notation' + + open(33, file='Lmat_tilde.dat', action='write') + do n = 1, mo_num + do m = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + ! < i j k | -L | l m n > with a BI-ORTHONORMAL MOLECULAR ORBITALS + call give_integrals_3_body_bi_ort(i, j, k, l, m, n, integral) + write(33, '(6(I4, 2X), 4X, E15.7)') i, j, k, l, m, n, integral + enddo + enddo + enddo + enddo + enddo + enddo + close(33) + + return +end subroutine LMat_tilde_dump + +! --- diff --git a/src/tc_bi_ortho/print_tc_energy.irp.f b/src/tc_bi_ortho/print_tc_energy.irp.f index 980d12de..b9f23a8a 100644 --- a/src/tc_bi_ortho/print_tc_energy.irp.f +++ b/src/tc_bi_ortho/print_tc_energy.irp.f @@ -1,19 +1,31 @@ program print_tc_energy - implicit none + BEGIN_DOC -! TODO : Put the documentation of the program here + ! TODO : Put the documentation of the program here END_DOC + + implicit none + print *, 'Hello world' my_grid_becke = .True. - my_n_pt_r_grid = 30 - my_n_pt_a_grid = 50 + !my_n_pt_r_grid = 30 + !my_n_pt_a_grid = 50 + + my_n_pt_r_grid = 100 + my_n_pt_a_grid = 170 + + !my_n_pt_r_grid = 100 + !my_n_pt_a_grid = 266 + read_wf = .True. touch read_wf PROVIDE j1b_type print*, 'j1b_type = ', j1b_type - touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - call write_tc_energy + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + call write_tc_energy() + end diff --git a/src/tc_bi_ortho/slater_tc_slow.irp.f b/src/tc_bi_ortho/slater_tc_slow.irp.f index 1833d20f..301cfe0f 100644 --- a/src/tc_bi_ortho/slater_tc_slow.irp.f +++ b/src/tc_bi_ortho/slater_tc_slow.irp.f @@ -55,7 +55,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, hmono = 0.d0 htwoe = 0.d0 htot = 0.d0 - hthree = 0.D0 + hthree = 0.d0 call get_excitation_degree(key_i, key_j, degree, Nint) if(degree.gt.2) return diff --git a/src/tc_keywords/j1b_pen.irp.f b/src/tc_keywords/j1b_pen.irp.f index ebcd5107..2d5e59a9 100644 --- a/src/tc_keywords/j1b_pen.irp.f +++ b/src/tc_keywords/j1b_pen.irp.f @@ -91,7 +91,7 @@ print *, ' parameters for nuclei jastrow' print *, ' i, Z, j1b_pen, j1b_pen_coef' do i = 1, nucl_num - print *, i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(i) + write(*,"(I4, 2x, 3(E15.7, 2X))"), i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(i) enddo END_PROVIDER diff --git a/src/tc_scf/fock_three_hermit.irp.f b/src/tc_scf/fock_three_hermit.irp.f index 89e6f620..a936da9b 100644 --- a/src/tc_scf/fock_three_hermit.irp.f +++ b/src/tc_scf/fock_three_hermit.irp.f @@ -78,6 +78,7 @@ end ! --- +! TODO DGEMM BEGIN_PROVIDER [double precision, diag_three_elem_hf] implicit none @@ -106,7 +107,7 @@ BEGIN_PROVIDER [double precision, diag_three_elem_hf] do i = 1, elec_beta_num do j = 1, elec_beta_num do k = 1, elec_beta_num - call give_integrals_3_body(k, j, i, j, i, k,exchange_int_231) + call give_integrals_3_body(k, j, i, j, i, k, exchange_int_231) diag_three_elem_hf += two_third * exchange_int_231 enddo enddo