mirror of
https://github.com/TREX-CoE/irpjast.git
synced 2024-07-03 09:56:11 +02:00
156 lines
4.9 KiB
Fortran
156 lines
4.9 KiB
Fortran
BEGIN_PROVIDER [ double precision, tmp_c, (nelec_8,nnuc,0:ncord,0:ncord-1) ]
|
|
&BEGIN_PROVIDER [ double precision, dtmp_c, (nelec_8,4,nnuc,0:ncord,0:ncord-1) ]
|
|
use qmckl_blas
|
|
implicit none
|
|
BEGIN_DOC
|
|
! Calculate the intermediate buffers
|
|
! tmp_c:
|
|
! r_{ij}^k . R_{ja}^l -> tmp_c_{ia}^{kl}
|
|
!
|
|
! dtmp_c:
|
|
! dr_{ij}^k . R_{ja}^l -> dtmp_c_{ia}^{kl}
|
|
END_DOC
|
|
integer :: k, l, m
|
|
integer*8 :: tasks(100000), ntasks
|
|
|
|
ntasks = 0_8
|
|
|
|
! type(c_ptr) :: ptr_a, ptr_b, ptr_c, ptr_d, ptr_e
|
|
! double precision, pointer :: A(:,:,:), B(:,:,:), C(:,:,:,:), D(:,:,:,:), E(:,:,:,:,:)
|
|
|
|
! call alloc(ptr_a, int(size(rescale_een_e),8))
|
|
! call c_f_pointer(ptr_a, A, shape(rescale_een_e))
|
|
! A(:,:,:) = rescale_een_e(:,:,:)
|
|
!
|
|
! call alloc(ptr_b, int(size(rescale_een_n),8))
|
|
! call c_f_pointer(ptr_b, B, shape(rescale_een_n))
|
|
! B(:,:,:) = rescale_een_n(:,:,:)
|
|
!
|
|
! call alloc(ptr_c, int(size(tmp_c),8))
|
|
! call c_f_pointer(ptr_c, C, shape(tmp_c))
|
|
|
|
! r_{ij}^k . R_{ja}^l -> tmp_c_{ia}^{kl}
|
|
do k=0,ncord-1
|
|
do l=0,ncord
|
|
call qmckl_dgemm('N','N', nelec, nnuc, nelec, 1.d0, &
|
|
rescale_een_e(1,1,k), size(rescale_een_e,1), &
|
|
rescale_een_n(1,1,l), size(rescale_een_n,1), 0.d0, &
|
|
tmp_c(1,1,l,k), size(tmp_c,1), tasks, ntasks)
|
|
! call qmckl_dgemm('N','N', nelec, nnuc, nelec, 1.d0, &
|
|
! A(:,:,k), size(rescale_een_e,1), &
|
|
! B(:,:,l), size(rescale_een_n,1), 0.d0, &
|
|
! C(:,:,l,k), size(tmp_c,1), tasks, ntasks)
|
|
enddo
|
|
enddo
|
|
|
|
!call alloc(ptr_d, int(size(rescale_een_e_deriv_e),8))
|
|
!call c_f_pointer(ptr_d, D, shape(rescale_een_e_deriv_e))
|
|
!D(:,:,:,:) = rescale_een_e_deriv_e(:,:,:,:)
|
|
|
|
!call alloc(ptr_e, int(size(dtmp_c),8))
|
|
!call c_f_pointer(ptr_e, E, shape(dtmp_c))
|
|
|
|
! dr_{ij}^k . R_{ja}^l -> dtmp_c_{ia}^{kl}
|
|
do k=0,ncord-1
|
|
do l=0,ncord
|
|
call qmckl_dgemm('N','N', nelec_8*4, nnuc, nelec, 1.d0, &
|
|
rescale_een_e_deriv_e(1,1,1,k), &
|
|
size(rescale_een_e_deriv_e,1)*size(rescale_een_e_deriv_e,2), &
|
|
rescale_een_n(1,1,l), &
|
|
size(rescale_een_n,1), 0.d0, &
|
|
dtmp_c(1,1,1,l,k), size(dtmp_c,1)*size(dtmp_c,2), &
|
|
tasks, ntasks)
|
|
|
|
! call qmckl_dgemm('N','N', nelec_8*4, nnuc, nelec, 1.d0, &
|
|
! D(:,:,:,k), &
|
|
! size(rescale_een_e_deriv_e,1)*size(rescale_een_e_deriv_e,2), &
|
|
! B(:,:,l), &
|
|
! size(rescale_een_n,1), 0.d0, &
|
|
! E(:,:,:,l,k), size(dtmp_c,1)*size(dtmp_c,2), &
|
|
! tasks, ntasks)
|
|
enddo
|
|
enddo
|
|
|
|
print *, ntasks, ' tasks'
|
|
call qmckl_tasks_run(tasks, ntasks)
|
|
! tmp_c(:,:,:,:) = C(:,:,:,:)
|
|
! dtmp_c(:,:,:,:,:) = E(:,:,:,:,:)
|
|
! call free(ptr_a)
|
|
! call free(ptr_b)
|
|
! call free(ptr_c)
|
|
! call free(ptr_d)
|
|
! call free(ptr_e)
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
BEGIN_PROVIDER [ double precision, factor_een_blas ]
|
|
&BEGIN_PROVIDER [ double precision, factor_een_deriv_e_blas, (nelec_8,4) ]
|
|
implicit none
|
|
BEGIN_DOC
|
|
! Dimensions 1-3 : dx, dy, dz
|
|
! Dimension 4 : d2x + d2y + d2z
|
|
END_DOC
|
|
|
|
integer :: i, j, a, p, k, l, lmax, m, n, ii
|
|
double precision :: accu, cn, cn2
|
|
! double precision,dimension(:),allocatable :: cn
|
|
|
|
factor_een_blas = 0.0d0
|
|
factor_een_deriv_e_blas(:,:) = 0.0d0
|
|
|
|
do n = 1, dim_cord_vect
|
|
|
|
l = lkpm_of_cindex(1,n)
|
|
k = lkpm_of_cindex(2,n)
|
|
p = lkpm_of_cindex(3,n)
|
|
m = lkpm_of_cindex(4,n)
|
|
|
|
do a = 1, nnuc
|
|
cn = cord_vect_full(n, a)
|
|
if (cn == 0.d0) cycle
|
|
|
|
accu = 0.d0
|
|
do j=1,nelec
|
|
accu = accu + rescale_een_n(j,a,m) * tmp_c(j,a,m+l,k)
|
|
enddo
|
|
factor_een_blas = factor_een_blas + accu * cn
|
|
|
|
cn2 = cn+cn
|
|
do ii=1,4
|
|
do j=1,nelec
|
|
factor_een_deriv_e_blas(j,ii) = factor_een_deriv_e_blas(j,ii) + (&
|
|
tmp_c (j,a,m+l,k) *rescale_een_n_deriv_e(j,ii,a,m) + &
|
|
dtmp_c(j,ii,a,m+l,k) * rescale_een_n(j,a,m) ) * cn
|
|
enddo
|
|
enddo
|
|
|
|
do j=1,nelec
|
|
factor_een_deriv_e_blas(j,4) = factor_een_deriv_e_blas(j,4) + (&
|
|
dtmp_c(j,1,a,m+l,k) * rescale_een_n_deriv_e(j,1,a,m ) + &
|
|
dtmp_c(j,2,a,m+l,k) * rescale_een_n_deriv_e(j,2,a,m ) + &
|
|
dtmp_c(j,3,a,m+l,k) * rescale_een_n_deriv_e(j,3,a,m ) &
|
|
)*cn2
|
|
enddo
|
|
|
|
do ii=1,4
|
|
do j=1,nelec
|
|
factor_een_deriv_e_blas(j,ii) = factor_een_deriv_e_blas(j,ii) + (&
|
|
tmp_c(j,a,m,k) * rescale_een_n_deriv_e(j,ii,a,m+l) + &
|
|
dtmp_c(j,ii,a,m,k) * rescale_een_n(j,a,m+l) ) * cn
|
|
enddo
|
|
enddo
|
|
|
|
do j=1,nelec
|
|
factor_een_deriv_e_blas(j,4) = factor_een_deriv_e_blas(j,4) + (&
|
|
dtmp_c(j,1,a,m ,k) * rescale_een_n_deriv_e(j,1,a,m+l) + &
|
|
dtmp_c(j,2,a,m ,k) * rescale_een_n_deriv_e(j,2,a,m+l) + &
|
|
dtmp_c(j,3,a,m ,k) * rescale_een_n_deriv_e(j,3,a,m+l) &
|
|
)*cn2
|
|
enddo
|
|
|
|
enddo
|
|
enddo
|
|
|
|
END_PROVIDER
|