9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-23 20:13:42 +01:00
qp2/plugins/local/tc_progs/print_tc_dump.irp.f

188 lines
4.6 KiB
Fortran
Raw Normal View History

2023-06-22 22:04:57 +02:00
program tc_bi_ortho
BEGIN_DOC
! TODO
END_DOC
implicit none
my_grid_becke = .True.
2023-07-02 21:49:25 +02:00
PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r
my_n_pt_a_grid = tc_grid1_a
2023-06-22 22:04:57 +02:00
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
2023-06-24 18:54:32 +02:00
call ERI_dump()
2023-06-22 22:04:57 +02:00
call KMat_tilde_dump()
2023-06-24 18:54:32 +02:00
call LMat_tilde_dump()
2023-06-22 22:04:57 +02:00
end
! ---
subroutine KMat_tilde_dump()
implicit none
2023-06-28 18:57:41 +02:00
integer :: i, j, k, l
integer :: isym, ms2, st, iii
character(16) :: corb
double precision :: t1, t2
integer, allocatable :: orbsym(:)
2023-06-22 22:04:57 +02:00
2023-06-28 18:57:41 +02:00
print *, ' generating FCIDUMP'
call wall_time(t1)
2023-06-22 22:04:57 +02:00
2023-06-28 18:57:41 +02:00
PROVIDE mo_bi_ortho_tc_two_e_chemist
PROVIDE mo_bi_ortho_tc_one_e
isym = 1
ms2 = elec_alpha_num - elec_beta_num
st = 0
iii = 0
allocate(orbsym(mo_num))
orbsym(1:mo_num) = 1
open(33, file='FCIDUMP', action='write')
write(33,'("&",a)') 'FCI'
write(33,'(1x,a,"=",i0,",")') 'NORB', mo_num
write(33,'(1x,a,"=",i0,",")') 'NELEC', elec_num
write(33,'(1x,a,"=",i0,",")') 'MS2', ms2
write(33,'(1x,a,"=",i0,",")') 'ISYM', isym
write(corb,'(i0)') mo_num
write(33,'(1x,a,"=",'//corb//'(i0,","))') 'ORBSYM', orbsym
write(33,'(1x,a,"=",i0,",")') 'ST', st
write(33,'(1x,a,"=",i0,",")') 'III', iii
write(33,'(1x,a,"=",i0,",")') 'OCC', (elec_num-ms2)/2+ms2
write(33,'(1x,a,"=",i0,",")') 'CLOSED', 2*elec_alpha_num
write(33,'(1x,"/")')
2023-06-22 22:04:57 +02:00
do l = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do i = 1, mo_num
! TCHint convention
2023-07-04 22:17:31 +02:00
write(33, '(ES15.7, 4X, 4(I4, 2X))') mo_bi_ortho_tc_two_e_chemist(j,i,l,k), i, j, k, l
2023-06-22 22:04:57 +02:00
enddo
enddo
enddo
enddo
2023-06-28 18:57:41 +02:00
do j = 1, mo_num
do i = 1, mo_num
! TCHint convention
2023-07-04 22:17:31 +02:00
write(33, '(ES15.7, 4X, 4(I4, 2X))') mo_bi_ortho_tc_one_e(i,j), i, j, 0, 0
2023-06-28 18:57:41 +02:00
enddo
enddo
2023-06-22 22:04:57 +02:00
close(33)
2023-06-28 18:57:41 +02:00
deallocate(orbsym)
call wall_time(t2)
print *, ' end after (min)', (t2-t1)/60.d0
2023-06-22 22:04:57 +02:00
return
end subroutine KMat_tilde_dump
! ---
2023-06-24 18:54:32 +02:00
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
2023-07-04 22:17:31 +02:00
write(33, '(4(I4, 2X), 4X, ES15.7)') i, j, k, l, a1(i,j,k,l)
2023-06-24 18:54:32 +02:00
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
2023-06-28 18:57:41 +02:00
double precision :: t1, t2
2023-06-24 18:54:32 +02:00
2023-06-28 18:57:41 +02:00
print *, ' generating TCDUMP'
call wall_time(t1)
2023-06-24 18:54:32 +02:00
2023-06-28 18:57:41 +02:00
PROVIDE mo_l_coef mo_r_coef
2023-06-24 18:54:32 +02:00
2023-06-28 18:57:41 +02:00
open(33, file='TCDUMP', action='write')
write(33, '(4X, I4)') mo_num
2023-06-24 18:54:32 +02:00
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)
2023-06-28 18:57:41 +02:00
!write(33, '(6(I4, 2X), 4X, E15.7)') i, j, k, l, m, n, integral
! TCHint convention
if(dabs(integral).gt.1d-10) then
2023-07-04 22:17:31 +02:00
write(33, '(ES15.7, 4X, 6(I4, 2X))') -integral/3.d0, i, j, k, l, m, n
!write(33, '(ES15.7, 4X, 6(I4, 2X))') -integral/3.d0, l, m, n, i, j, k
2023-06-28 18:57:41 +02:00
endif
2023-06-24 18:54:32 +02:00
enddo
enddo
enddo
enddo
enddo
enddo
close(33)
2023-06-28 18:57:41 +02:00
call wall_time(t2)
print *, ' end after (min)', (t2-t1)/60.d0
2023-06-24 18:54:32 +02:00
return
end subroutine LMat_tilde_dump
! ---