irpjast/el_nuc_el_blas.irp.f

 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