LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-10-09 01:17:19 +02:00
Code Releases Activity
f07db955f8
qp2/src/utils/integration.irp.f

1434 lines
38 KiB
Fortran
Raw Normal View History

Initial commit
2019-01-25 11:39:31 +01:00
subroutine give_explicit_poly_and_gaussian_x(P_new,P_center,p,fact_k,iorder,alpha,beta,a,b,A_center,B_center,dim)
BEGIN_DOC
! Transform the product of
! (x-x_A)^a(1) (x-x_B)^b(1) (x-x_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3) exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta)
! into
! fact_k (x-x_P)^iorder(1) (y-y_P)^iorder(2) (z-z_P)^iorder(3) exp(-p(r-P)^2)
END_DOC
implicit none
include 'constants.include.F'
integer, intent(in) :: dim
integer, intent(in) :: a,b ! powers : (x-xa)**a_x = (x-A(1))**a(1)
double precision, intent(in) :: alpha, beta ! exponents
double precision, intent(in) :: A_center ! A center
double precision, intent(in) :: B_center ! B center
double precision, intent(out) :: P_center ! new center
double precision, intent(out) :: p ! new exponent
double precision, intent(out) :: fact_k ! constant factor
double precision, intent(out) :: P_new(0:max_dim) ! polynomial
integer, intent(out) :: iorder ! order of the polynomials
double precision :: P_a(0:max_dim), P_b(0:max_dim)
integer :: n_new,i,j
double precision :: p_inv,ab,d_AB
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: P_a, P_b
! Do the gaussian product to get the new center and the new exponent
P_new = 0.d0
p = alpha+beta
p_inv = 1.d0/p
ab = alpha * beta
d_AB = (A_center - B_center) * (A_center - B_center)
P_center = (alpha * A_center + beta * B_center) * p_inv
minor changes
2020-08-07 11:47:51 +02:00
if(dabs(ab*p_inv * d_AB).lt.50.d0)then
fact_k = exp(-ab*p_inv * d_AB)
else
fact_k = 0.d0
endif
Initial commit
2019-01-25 11:39:31 +01:00
! Recenter the polynomials P_a and P_b on x
!DIR$ FORCEINLINE
call recentered_poly2(P_a(0),A_center,P_center,a,P_b(0),B_center,P_center,b)
n_new = 0
!DIR$ FORCEINLINE
call multiply_poly(P_a(0),a,P_b(0),b,P_new(0),n_new)
iorder = a + b
end
subroutine give_explicit_poly_and_gaussian(P_new,P_center,p,fact_k,iorder,alpha,beta,a,b,A_center,B_center,dim)
BEGIN_DOC
! Transforms the product of
! (x-x_A)^a(1) (x-x_B)^b(1) (x-x_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3) exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta)
! into
! fact_k * [ sum (l_x = 0,i_order(1)) P_new(l_x,1) * (x-P_center(1))^l_x ] exp (- p (x-P_center(1))^2 )
! * [ sum (l_y = 0,i_order(2)) P_new(l_y,2) * (y-P_center(2))^l_y ] exp (- p (y-P_center(2))^2 )
! * [ sum (l_z = 0,i_order(3)) P_new(l_z,3) * (z-P_center(3))^l_z ] exp (- p (z-P_center(3))^2 )
fixed bug in give_explicit_poly_and_gaussian
2021-06-28 11:52:06 +02:00
!
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
! WARNING ::: IF fact_k is too smal then:
fixed bug in give_explicit_poly_and_gaussian
2021-06-28 11:52:06 +02:00
! returns a "s" function centered in zero
! with an inifinite exponent and a zero polynom coef
Initial commit
2019-01-25 11:39:31 +01:00
END_DOC
implicit none
include 'constants.include.F'
integer, intent(in) :: dim
integer, intent(in) :: a(3),b(3) ! powers : (x-xa)**a_x = (x-A(1))**a(1)
double precision, intent(in) :: alpha, beta ! exponents
double precision, intent(in) :: A_center(3) ! A center
double precision, intent(in) :: B_center (3) ! B center
double precision, intent(out) :: P_center(3) ! new center
double precision, intent(out) :: p ! new exponent
double precision, intent(out) :: fact_k ! constant factor
double precision, intent(out) :: P_new(0:max_dim,3)! polynomial
integer, intent(out) :: iorder(3) ! i_order(i) = order of the polynomials
double precision :: P_a(0:max_dim,3), P_b(0:max_dim,3)
integer :: n_new,i,j
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: P_a, P_b
iorder(1) = 0
iorder(2) = 0
iorder(3) = 0
P_new(0,1) = 0.d0
P_new(0,2) = 0.d0
P_new(0,3) = 0.d0
!DIR$ FORCEINLINE
call gaussian_product(alpha,A_center,beta,B_center,fact_k,p,P_center)
if (fact_k < thresh) then
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
! IF fact_k is too smal then:
fixed bug in give_explicit_poly_and_gaussian
2021-06-28 11:52:06 +02:00
! returns a "s" function centered in zero
! with an inifinite exponent and a zero polynom coef
minor changes
2020-08-07 11:47:51 +02:00
P_center = 0.d0
fixed bug in give_explicit_poly_and_gaussian
2021-06-28 11:52:06 +02:00
p = 1.d+15
minor changes
2020-08-07 11:47:51 +02:00
P_new = 0.d0
fixed bug in give_explicit_poly_and_gaussian
2021-06-28 11:52:06 +02:00
iorder = 0
Initial commit
2019-01-25 11:39:31 +01:00
fact_k = 0.d0
return
endif
!DIR$ FORCEINLINE
call recentered_poly2(P_a(0,1),A_center(1),P_center(1),a(1),P_b(0,1),B_center(1),P_center(1),b(1))
iorder(1) = a(1) + b(1)
do i=0,iorder(1)
P_new(i,1) = 0.d0
enddo
n_new=0
!DIR$ FORCEINLINE
call multiply_poly(P_a(0,1),a(1),P_b(0,1),b(1),P_new(0,1),n_new)
!DIR$ FORCEINLINE
call recentered_poly2(P_a(0,2),A_center(2),P_center(2),a(2),P_b(0,2),B_center(2),P_center(2),b(2))
iorder(2) = a(2) + b(2)
do i=0,iorder(2)
P_new(i,2) = 0.d0
enddo
n_new=0
!DIR$ FORCEINLINE
call multiply_poly(P_a(0,2),a(2),P_b(0,2),b(2),P_new(0,2),n_new)
!DIR$ FORCEINLINE
call recentered_poly2(P_a(0,3),A_center(3),P_center(3),a(3),P_b(0,3),B_center(3),P_center(3),b(3))
iorder(3) = a(3) + b(3)
do i=0,iorder(3)
P_new(i,3) = 0.d0
enddo
n_new=0
!DIR$ FORCEINLINE
call multiply_poly(P_a(0,3),a(3),P_b(0,3),b(3),P_new(0,3),n_new)
end
non_h_ints compiles
2023-02-06 19:00:35 +01:00
subroutine give_explicit_poly_and_gaussian_v(P_new, ldp, P_center, p, fact_k, iorder, alpha, beta, a, b, A_center, LD_A, B_center, n_points)
BEGIN_DOC
! Transforms the product of
cos x GTOs integ added
2023-03-04 17:49:48 +01:00
! (x-x_A)^a(1) (x-x_B)^b(1) (y-y_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3) exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta)
non_h_ints compiles
2023-02-06 19:00:35 +01:00
! into
! fact_k * [ sum (l_x = 0,i_order(1)) P_new(l_x,1) * (x-P_center(1))^l_x ] exp (- p (x-P_center(1))^2 )
! * [ sum (l_y = 0,i_order(2)) P_new(l_y,2) * (y-P_center(2))^l_y ] exp (- p (y-P_center(2))^2 )
! * [ sum (l_z = 0,i_order(3)) P_new(l_z,3) * (z-P_center(3))^l_z ] exp (- p (z-P_center(3))^2 )
!
! WARNING :: : IF fact_k is too smal then:
! returns a "s" function centered in zero
! with an inifinite exponent and a zero polynom coef
END_DOC
include 'constants.include.F'
implicit none
integer, intent(in) :: n_points, ldp, LD_A
integer, intent(in) :: a(3), b(3) ! powers : (x-xa)**a_x = (x-A(1))**a(1)
double precision, intent(in) :: alpha, beta ! exponents
double precision, intent(in) :: A_center(LD_A,3) ! A center
double precision, intent(in) :: B_center(3) ! B center
integer, intent(out) :: iorder(3) ! i_order(i) = order of the polynomials
double precision, intent(out) :: P_center(n_points,3) ! new center
double precision, intent(out) :: p ! new exponent
double precision, intent(out) :: fact_k(n_points) ! constant factor
double precision, intent(out) :: P_new(n_points,0:ldp,3) ! polynomial
integer :: n_new, i, j, ipoint, lda, ldb, xyz
double precision, allocatable :: P_a(:,:,:), P_b(:,:,:)
call gaussian_product_v(alpha, A_center, LD_A, beta, B_center, fact_k, p, P_center, n_points)
if(ior(ior(b(1), b(2)), b(3)) == 0) then ! b == (0,0,0)
iorder(1:3) = a(1:3)
lda = maxval(a)
allocate(P_a(n_points,0:lda,3))
!ldb = 0
!allocate(P_b(n_points,0:0,3))
!call recentered_poly2_v0(P_a, lda, A_center, LD_A, P_center, a, P_b, B_center, P_center, n_points)
call recentered_poly2_v0(P_a, lda, A_center, LD_A, P_center, a, n_points)
do ipoint = 1, n_points
do xyz = 1, 3
!P_new(ipoint,0,xyz) = P_a(ipoint,0,xyz) * P_b(ipoint,0,xyz)
P_new(ipoint,0,xyz) = P_a(ipoint,0,xyz)
do i = 1, a(xyz)
!P_new(ipoint,i,xyz) = P_new(ipoint,i,xyz) + P_b(ipoint,0,xyz) * P_a(ipoint,i,xyz)
P_new(ipoint,i,xyz) = P_a(ipoint,i,xyz)
enddo
enddo
enddo
deallocate(P_a)
!deallocate(P_b)
return
endif
lda = maxval(a)
ldb = maxval(b)
allocate(P_a(n_points,0:lda,3), P_b(n_points,0:ldb,3))
call recentered_poly2_v(P_a, lda, A_center, LD_A, P_center, a, P_b, ldb, B_center, P_center, b, n_points)
iorder(1:3) = a(1:3) + b(1:3)
do xyz = 1, 3
if(b(xyz) == 0) then
do ipoint = 1, n_points
!P_new(ipoint,0,xyz) = P_a(ipoint,0,xyz) * P_b(ipoint,0,xyz)
P_new(ipoint,0,xyz) = P_a(ipoint,0,xyz)
do i = 1, a(xyz)
!P_new(ipoint,i,xyz) = P_new(ipoint,i,xyz) + P_b(ipoint,0,xyz) * P_a(ipoint,i,xyz)
P_new(ipoint,i,xyz) = P_a(ipoint,i,xyz)
enddo
enddo
else
do i = 0, iorder(xyz)
do ipoint = 1, n_points
P_new(ipoint,i,xyz) = 0.d0
enddo
enddo
call multiply_poly_v(P_a(1,0,xyz), a(xyz), P_b(1,0,xyz), b(xyz), P_new(1,0,xyz), ldp, n_points)
endif
enddo
end subroutine give_explicit_poly_and_gaussian_v
! ---
Initial commit
2019-01-25 11:39:31 +01:00
subroutine give_explicit_poly_and_gaussian_double(P_new,P_center,p,fact_k,iorder,alpha,beta,gama,a,b,A_center,B_center,Nucl_center,dim)
BEGIN_DOC
! Transforms the product of
! (x-x_A)^a(1) (x-x_B)^b(1) (x-x_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3)
! exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta) exp(-(r-Nucl_center)^2 gama
!
! into
! fact_k * [ sum (l_x = 0,i_order(1)) P_new(l_x,1) * (x-P_center(1))^l_x ] exp (- p (x-P_center(1))^2 )
! * [ sum (l_y = 0,i_order(2)) P_new(l_y,2) * (y-P_center(2))^l_y ] exp (- p (y-P_center(2))^2 )
! * [ sum (l_z = 0,i_order(3)) P_new(l_z,3) * (z-P_center(3))^l_z ] exp (- p (z-P_center(3))^2 )
END_DOC
implicit none
include 'constants.include.F'
integer, intent(in) :: dim
integer, intent(in) :: a(3),b(3) ! powers : (x-xa)**a_x = (x-A(1))**a(1)
double precision, intent(in) :: alpha, beta, gama ! exponents
double precision, intent(in) :: A_center(3) ! A center
double precision, intent(in) :: B_center (3) ! B center
double precision, intent(in) :: Nucl_center(3) ! B center
double precision, intent(out) :: P_center(3) ! new center
double precision, intent(out) :: p ! new exponent
double precision, intent(out) :: fact_k ! constant factor
double precision, intent(out) :: P_new(0:max_dim,3)! polynomial
integer , intent(out) :: iorder(3) ! i_order(i) = order of the polynomials
double precision :: P_center_tmp(3) ! new center
double precision :: p_tmp ! new exponent
double precision :: fact_k_tmp,fact_k_bis ! constant factor
double precision :: P_new_tmp(0:max_dim,3)! polynomial
integer :: i,j
double precision :: binom_func
! First you transform the two primitives into a sum of primitive with the same center P_center_tmp and gaussian exponent p_tmp
call give_explicit_poly_and_gaussian(P_new_tmp,P_center_tmp,p_tmp,fact_k_tmp,iorder,alpha,beta,a,b,A_center,B_center,dim)
! Then you create the new gaussian from the product of the new one per the Nuclei one
call gaussian_product(p_tmp,P_center_tmp,gama,Nucl_center,fact_k_bis,p,P_center)
fact_k = fact_k_bis * fact_k_tmp
! Then you build the coefficient of the new polynom
do i = 0, iorder(1)
P_new(i,1) = 0.d0
do j = i,iorder(1)
P_new(i,1) = P_new(i,1) + P_new_tmp(j,1) * binom_func(j,j-i) * (P_center(1) - P_center_tmp(1))**(j-i)
enddo
enddo
do i = 0, iorder(2)
P_new(i,2) = 0.d0
do j = i,iorder(2)
P_new(i,2) = P_new(i,2) + P_new_tmp(j,2) * binom_func(j,j-i) * (P_center(2) - P_center_tmp(2))**(j-i)
enddo
enddo
do i = 0, iorder(3)
P_new(i,3) = 0.d0
do j = i,iorder(3)
P_new(i,3) = P_new(i,3) + P_new_tmp(j,3) * binom_func(j,j-i) * (P_center(3) - P_center_tmp(3))**(j-i)
enddo
enddo
end
subroutine gaussian_product(a,xa,b,xb,k,p,xp)
implicit none
BEGIN_DOC
! Gaussian product in 1D.
! e^{-a (x-x_A)^2} e^{-b (x-x_B)^2} = K_{ab}^x e^{-p (x-x_P)^2}
END_DOC
double precision, intent(in) :: a,b ! Exponents
double precision, intent(in) :: xa(3),xb(3) ! Centers
double precision, intent(out) :: p ! New exponent
double precision, intent(out) :: xp(3) ! New center
double precision, intent(out) :: k ! Constant
double precision :: p_inv
ASSERT (a>0.)
ASSERT (b>0.)
double precision :: xab(3), ab
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xab
p = a+b
p_inv = 1.d0/(a+b)
ab = a*b
xab(1) = xa(1)-xb(1)
xab(2) = xa(2)-xb(2)
xab(3) = xa(3)-xb(3)
ab = ab*p_inv
k = ab*(xab(1)*xab(1)+xab(2)*xab(2)+xab(3)*xab(3))
if (k > 40.d0) then
k=0.d0
return
endif
k = dexp(-k)
xp(1) = (a*xa(1)+b*xb(1))*p_inv
xp(2) = (a*xa(2)+b*xb(2))*p_inv
xp(3) = (a*xa(3)+b*xb(3))*p_inv
end subroutine
non_h_ints compiles
2023-02-06 19:00:35 +01:00
subroutine gaussian_product_v(a, xa, LD_xa, b, xb, k, p, xp, n_points)
BEGIN_DOC
!
! Gaussian product in 1D.
! e^{-a (x-x_A)^2} e^{-b (x-x_B)^2} = K_{ab}^x e^{-p (x-x_P)^2}
!
! Using multiple A centers
!
END_DOC
implicit none
integer, intent(in) :: LD_xa, n_points
double precision, intent(in) :: a, b ! Exponents
double precision, intent(in) :: xa(LD_xa,3), xb(3) ! Centers
double precision, intent(out) :: p ! New exponent
double precision, intent(out) :: xp(n_points,3) ! New center
double precision, intent(out) :: k(n_points) ! Constant
integer :: ipoint
double precision :: p_inv
double precision :: xab(3), ab, ap, bp, bpxb(3)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xab
ASSERT (a>0.)
ASSERT (b>0.)
p = a+b
p_inv = 1.d0/(a+b)
ab = a*b*p_inv
ap = a*p_inv
bp = b*p_inv
bpxb(1) = bp*xb(1)
bpxb(2) = bp*xb(2)
bpxb(3) = bp*xb(3)
do ipoint = 1, n_points
xab(1) = xa(ipoint,1)-xb(1)
xab(2) = xa(ipoint,2)-xb(2)
xab(3) = xa(ipoint,3)-xb(3)
k(ipoint) = ab*(xab(1)*xab(1)+xab(2)*xab(2)+xab(3)*xab(3))
if (k(ipoint) > 40.d0) then
k(ipoint)=0.d0
xp(ipoint,1) = 0.d0
xp(ipoint,2) = 0.d0
xp(ipoint,3) = 0.d0
else
k(ipoint) = dexp(-k(ipoint))
xp(ipoint,1) = ap*xa(ipoint,1)+bpxb(1)
xp(ipoint,2) = ap*xa(ipoint,2)+bpxb(2)
xp(ipoint,3) = ap*xa(ipoint,3)+bpxb(3)
endif
enddo
end subroutine gaussian_product_v
! ---
Initial commit
2019-01-25 11:39:31 +01:00
subroutine gaussian_product_x(a,xa,b,xb,k,p,xp)
implicit none
BEGIN_DOC
! Gaussian product in 1D.
! e^{-a (x-x_A)^2} e^{-b (x-x_B)^2} = K_{ab}^x e^{-p (x-x_P)^2}
END_DOC
double precision , intent(in) :: a,b ! Exponents
double precision , intent(in) :: xa,xb ! Centers
double precision , intent(out) :: p ! New exponent
double precision , intent(out) :: xp ! New center
double precision , intent(out) :: k ! Constant
double precision :: p_inv
ASSERT (a>0.)
ASSERT (b>0.)
double precision :: xab, ab
p = a+b
p_inv = 1.d0/(a+b)
ab = a*b
xab = xa-xb
ab = ab*p_inv
k = ab*xab*xab
\int dr2 phi_i(r2) phi_j(r2) u(r12) v_1b(r2)
2023-07-02 00:19:17 +02:00
if (k > 400.d0) then
Initial commit
2019-01-25 11:39:31 +01:00
k=0.d0
return
endif
k = exp(-k)
xp = (a*xa+b*xb)*p_inv
end subroutine
cos x GTOs integ added
2023-03-04 17:49:48 +01:00
!-
subroutine gaussian_product_x_v(a,xa,b,xb,k,p,xp,n_points)
implicit none
BEGIN_DOC
! Gaussian product in 1D with multiple xa
! e^{-a (x-x_A)^2} e^{-b (x-x_B)^2} = K_{ab}^x e^{-p (x-x_P)^2}
END_DOC
integer, intent(in) :: n_points
double precision , intent(in) :: a,b ! Exponents
double precision , intent(in) :: xa(n_points),xb ! Centers
double precision , intent(out) :: p(n_points) ! New exponent
double precision , intent(out) :: xp(n_points) ! New center
double precision , intent(out) :: k(n_points) ! Constant
double precision :: p_inv
integer :: ipoint
ASSERT (a>0.)
ASSERT (b>0.)
double precision :: xab, ab
p = a+b
p_inv = 1.d0/(a+b)
ab = a*b*p_inv
do ipoint = 1, n_points
xab = xa(ipoint)-xb
k(ipoint) = ab*xab*xab
if (k(ipoint) > 40.d0) then
k(ipoint)=0.d0
cycle
endif
k(ipoint) = exp(-k(ipoint))
xp(ipoint) = (a*xa(ipoint)+b*xb)*p_inv
enddo
end subroutine
Initial commit
2019-01-25 11:39:31 +01:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
subroutine multiply_poly(b,nb,c,nc,d,nd)
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nb, nc
integer, intent(out) :: nd
double precision, intent(in) :: b(0:nb), c(0:nc)
double precision, intent(inout) :: d(0:nb+nc)
integer :: ndtmp
integer :: ib, ic, id, k
if(ior(nc,nb) < 0) return !False if nc>=0 and nb>=0
Optimized three_e_5_idx_exch12_bi_ort
2023-06-02 00:33:37 +02:00
select case (nb)
case (0)
call multiply_poly_b0(b,c,nc,d,nd)
return
case (1)
call multiply_poly_b1(b,c,nc,d,nd)
return
case (2)
call multiply_poly_b2(b,c,nc,d,nd)
return
end select
select case (nc)
case (0)
call multiply_poly_c0(b,nb,c,d,nd)
return
case (1)
call multiply_poly_c1(b,nb,c,d,nd)
return
case (2)
call multiply_poly_c2(b,nb,c,d,nd)
return
end select
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
do ib=0,nb
do ic = 0,nc
d(ib+ic) = d(ib+ic) + c(ic) * b(ib)
enddo
enddo
do nd = nb+nc,0,-1
if (d(nd) /= 0.d0) exit
enddo
end
subroutine multiply_poly_b0(b,c,nc,d,nd)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nc
integer, intent(out) :: nd
double precision, intent(in) :: b(0:0), c(0:nc)
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
double precision, intent(inout) :: d(0:nc)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
integer :: ndtmp
integer :: ic, id, k
if(nc < 0) return !False if nc>=0
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
do ic = 0,nc
d(ic) = d(ic) + c(ic) * b(0)
enddo
do nd = nc,0,-1
if (d(nd) /= 0.d0) exit
enddo
end
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
subroutine multiply_poly_b1(b,c,nc,d,nd)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nc
integer, intent(out) :: nd
double precision, intent(in) :: b(0:1), c(0:nc)
double precision, intent(inout) :: d(0:1+nc)
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
integer :: ndtmp
integer :: ib, ic, id, k
if(nc < 0) return !False if nc>=0
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
select case (nc)
case (0)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1)
case (1)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(1) * b(1)
case default
d(0) = d(0) + c(0) * b(0)
do ic = 1,nc
d(ic) = d(ic) + c(ic) * b(0) + c(ic-1) * b(1)
enddo
d(nc+1) = d(nc+1) + c(nc) * b(1)
end select
do nd = 1+nc,0,-1
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
if (d(nd) /= 0.d0) exit
enddo
end
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
subroutine multiply_poly_b2(b,c,nc,d,nd)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nc
integer, intent(out) :: nd
double precision, intent(in) :: b(0:2), c(0:nc)
double precision, intent(inout) :: d(0:2+nc)
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
integer :: ndtmp
integer :: ib, ic, id, k
if(nc < 0) return !False if nc>=0
select case (nc)
case (0)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1)
d(2) = d(2) + c(0) * b(2)
case (1)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(0) * b(2) + c(1) * b(1)
d(3) = d(3) + c(1) * b(2)
case (2)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(0) * b(2) + c(1) * b(1) + c(2) * b(0)
d(3) = d(3) + c(2) * b(1) + c(1) * b(2)
d(4) = d(4) + c(2) * b(2)
case default
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
do ic = 2,nc
d(ic) = d(ic) + c(ic) * b(0) + c(ic-1) * b(1) + c(ic-2) * b(2)
enddo
d(nc+1) = d(nc+1) + c(nc) * b(1) + c(nc-1) * b(2)
d(nc+2) = d(nc+2) + c(nc) * b(2)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
end select
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
do nd = 2+nc,0,-1
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
if (d(nd) /= 0.d0) exit
enddo
end
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
subroutine multiply_poly_c0(b,nb,c,d,nd)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
integer, intent(in) :: nb
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
integer, intent(out) :: nd
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
double precision, intent(in) :: b(0:nb), c(0:0)
double precision, intent(inout) :: d(0:nb)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
integer :: ndtmp
integer :: ib, ic, id, k
if(nb < 0) return !False if nb>=0
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
do ib=0,nb
d(ib) = d(ib) + c(0) * b(ib)
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
enddo
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
do nd = nb,0,-1
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
if (d(nd) /= 0.d0) exit
enddo
end
Initial commit
2019-01-25 11:39:31 +01:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
subroutine multiply_poly_c1(b,nb,c,d,nd)
Initial commit
2019-01-25 11:39:31 +01:00
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
integer, intent(in) :: nb
Initial commit
2019-01-25 11:39:31 +01:00
integer, intent(out) :: nd
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
double precision, intent(in) :: b(0:nb), c(0:1)
double precision, intent(inout) :: d(0:nb+1)
Initial commit
2019-01-25 11:39:31 +01:00
integer :: ndtmp
integer :: ib, ic, id, k
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
if(nb < 0) return !False if nb>=0
select case (nb)
case (0)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(1) * b(0)
case (1)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(1) * b(1)
case default
d(0) = d(0) + c(0) * b(0)
do ib=1,nb
d(ib) = d(ib) + c(0) * b(ib) + c(1) * b(ib-1)
enddo
d(nb+1) = d(nb+1) + c(1) * b(nb)
Initial commit
2019-01-25 11:39:31 +01:00
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
end select
do nd = nb+1,0,-1
if (d(nd) /= 0.d0) exit
Initial commit
2019-01-25 11:39:31 +01:00
enddo
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
end
subroutine multiply_poly_c2(b,nb,c,d,nd)
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nb
integer, intent(out) :: nd
double precision, intent(in) :: b(0:nb), c(0:2)
double precision, intent(inout) :: d(0:nb+2)
integer :: ndtmp
integer :: ib, ic, id, k
if(nb < 0) return !False if nb>=0
select case (nb)
case (0)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(1) * b(0)
d(2) = d(2) + c(2) * b(0)
case (1)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(1) * b(1) + c(2) * b(0)
d(3) = d(3) + c(2) * b(1)
case (2)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(0) * b(2) + c(1) * b(1) + c(2) * b(0)
d(3) = d(3) + c(1) * b(2) + c(2) * b(1)
d(4) = d(4) + c(2) * b(2)
case default
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
do ib=2,nb
d(ib) = d(ib) + c(0) * b(ib) + c(1) * b(ib-1) + c(2) * b(ib-2)
enddo
d(nb+1) = d(nb+1) + c(1) * b(nb) + c(2) * b(nb-1)
d(nb+2) = d(nb+2) + c(2) * b(nb)
end select
do nd = nb+2,0,-1
Inlined multiply_poly
2023-05-15 19:46:06 +02:00
if (d(nd) /= 0.d0) exit
Initial commit
2019-01-25 11:39:31 +01:00
enddo
end
Accelerated multiply_poly
2023-06-01 21:42:02 +02:00
non_h_ints compiles
2023-02-06 19:00:35 +01:00
subroutine multiply_poly_v(b,nb,c,nc,d,nd,n_points)
implicit none
BEGIN_DOC
! Multiply pairs of polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nb, nc, n_points
integer, intent(in) :: nd
double precision, intent(in) :: b(n_points,0:nb), c(n_points,0:nc)
double precision, intent(inout) :: d(n_points,0:nd)
integer :: ib, ic, id, k, ipoint
if (nd < nb+nc) then
print *, nd, nb, nc
print *, irp_here, ': nd < nb+nc'
stop 1
endif
do ic = 0,nc
do ipoint=1, n_points
d(ipoint,ic) = d(ipoint,ic) + c(ipoint,ic) * b(ipoint,0)
enddo
enddo
do ib=1,nb
do ipoint=1, n_points
d(ipoint, ib) = d(ipoint, ib) + c(ipoint,0) * b(ipoint, ib)
enddo
do ic = 1,nc
do ipoint=1, n_points
d(ipoint, ib+ic) = d(ipoint, ib+ic) + c(ipoint,ic) * b(ipoint, ib)
enddo
enddo
enddo
cos x GTOs integ added
2023-03-04 17:49:48 +01:00
non_h_ints compiles
2023-02-06 19:00:35 +01:00
end
cos x GTOs integ added
2023-03-04 17:49:48 +01:00
Initial commit
2019-01-25 11:39:31 +01:00
subroutine add_poly(b,nb,c,nc,d,nd)
implicit none
BEGIN_DOC
! Add two polynomials
! D(t) += B(t)+C(t)
END_DOC
integer, intent(inout) :: nb, nc
integer, intent(out) :: nd
double precision, intent(in) :: b(0:nb), c(0:nc)
double precision, intent(out) :: d(0:nb+nc)
nd = nb+nc
integer :: ib, ic, id
do ib=0,max(nb,nc)
d(ib) = d(ib) + c(ib) + b(ib)
enddo
do while ( (d(nd) == 0.d0).and.(nd>=0) )
nd -= 1
if (nd < 0) then
exit
endif
enddo
end
subroutine add_poly_multiply(b,nb,cst,d,nd)
implicit none
BEGIN_DOC
! Add a polynomial multiplied by a constant
! D(t) += cst * B(t)
END_DOC
integer, intent(in) :: nb
integer, intent(inout) :: nd
double precision, intent(in) :: b(0:nb),cst
double precision, intent(inout) :: d(0:max(nb,nd))
nd = max(nd,nb)
if (nd /= -1) then
integer :: ib, ic, id
do ib=0,nb
d(ib) = d(ib) + cst*b(ib)
enddo
do while ( d(nd) == 0.d0 )
nd -= 1
if (nd < 0) then
exit
endif
enddo
endif
end
non_h_ints compiles
2023-02-06 19:00:35 +01:00
subroutine recentered_poly2_v(P_new, lda, x_A, LD_xA, x_P, a, P_new2, ldb, x_B, x_Q, b, n_points)
BEGIN_DOC
! Recenter two polynomials
END_DOC
implicit none
integer, intent(in) :: a(3), b(3), n_points, lda, ldb, LD_xA
double precision, intent(in) :: x_A(LD_xA,3), x_P(n_points,3), x_B(3), x_Q(n_points,3)
double precision, intent(out) :: P_new(n_points,0:lda,3),P_new2(n_points,0:ldb,3)
double precision :: binom_func
integer :: i,j,k,l, minab(3), maxab(3),ipoint, xyz
double precision, allocatable :: pows_a(:,:), pows_b(:,:)
double precision :: fa, fb
maxab(1:3) = max(a(1:3),b(1:3))
minab(1:3) = max(min(a(1:3),b(1:3)),(/0,0,0/))
allocate( pows_a(n_points,-2:maxval(maxab)+4), pows_b(n_points,-2:maxval(maxab)+4) )
do xyz=1,3
if ((a(xyz)<0).or.(b(xyz)<0) ) cycle
do ipoint=1,n_points
pows_a(ipoint,0) = 1.d0
pows_a(ipoint,1) = (x_P(ipoint,xyz) - x_A(ipoint,xyz))
pows_b(ipoint,0) = 1.d0
pows_b(ipoint,1) = (x_Q(ipoint,xyz) - x_B(xyz))
enddo
do i = 2,maxab(xyz)
do ipoint=1,n_points
pows_a(ipoint,i) = pows_a(ipoint,i-1)*pows_a(ipoint,1)
pows_b(ipoint,i) = pows_b(ipoint,i-1)*pows_b(ipoint,1)
enddo
enddo
do ipoint=1,n_points
P_new (ipoint,0,xyz) = pows_a(ipoint,a(xyz))
P_new2(ipoint,0,xyz) = pows_b(ipoint,b(xyz))
enddo
do i = 1,min(minab(xyz),20)
fa = binom_transp(a(xyz)-i,a(xyz))
fb = binom_transp(b(xyz)-i,b(xyz))
do ipoint=1,n_points
P_new (ipoint,i,xyz) = fa * pows_a(ipoint,a(xyz)-i)
P_new2(ipoint,i,xyz) = fb * pows_b(ipoint,b(xyz)-i)
enddo
enddo
do i = minab(xyz)+1,min(a(xyz),20)
fa = binom_transp(a(xyz)