mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-22 12:23:43 +01:00
removed stupid stuffs in spher_harm
This commit is contained in:
eginer
parent
a730559eaf
commit
5c69a7c005
@ -2,3 +2,6 @@
|
||||
spher_harm
|
||||
==========
|
||||
|
||||
Routines for spherical Harmonics evaluation in real space.
|
||||
The main routine is "spher_harm_func_r3(r,l,m,re_ylm, im_ylm)".
|
||||
The test routine is "test_spher_harm" where everything is explained in details.
|
||||
|
||||
@ -1,10 +1,93 @@
|
||||
subroutine test_spher_harm
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! routine to test the generic spherical harmonics routine "spher_harm_func_r3" from R^3 --> C
|
||||
!
|
||||
! We test <Y_l1,m1|Y_l2,m2> = delta_m1,m2 delta_l1,l2
|
||||
!
|
||||
! The test is done through the integration on a sphere with the Lebedev grid.
|
||||
END_DOC
|
||||
include 'constants.include.F'
|
||||
integer :: l1,m1,i,l2,m2,lmax
|
||||
double precision :: r(3),weight,accu_re, accu_im,accu
|
||||
double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
|
||||
double precision :: theta,phi,r_abs
|
||||
lmax = 5 ! Maximum angular momentum until which we are going to test orthogonality conditions
|
||||
do l1 = 0,lmax
|
||||
do m1 = -l1 ,l1
|
||||
do l2 = 0,lmax
|
||||
do m2 = -l2 ,l2
|
||||
accu_re = 0.d0 ! accumulator for the REAL part of <Y_l1,m1|Y_l2,m2>
|
||||
accu_im = 0.d0 ! accumulator for the IMAGINARY part of <Y_l1,m1|Y_l2,m2>
|
||||
accu = 0.d0 ! accumulator for the weights ==> should be \int dOmega == 4 pi
|
||||
! <l1,m1|l2,m2> = \int dOmega Y_l1,m1^* Y_l2,m2
|
||||
! \approx \sum_i W_i Y_l1,m1^*(r_i) Y_l2,m2(r_i) WITH r_i being on the spher of radius 1
|
||||
do i = 1, n_points_integration_angular
|
||||
r(1:3) = angular_quadrature_points(i,1:3) ! ith Lebedev point (x,y,z) on the sphere of radius 1
|
||||
weight = weights_angular_points(i) ! associated Lebdev weight not necessarily positive
|
||||
|
||||
!!!!!!!!!!! Test of the Cartesian --> Spherical coordinates
|
||||
! theta MUST belong to [0,pi] and phi to [0,2pi]
|
||||
! gets the cartesian to spherical change of coordinates
|
||||
call cartesian_to_spherical(r,theta,phi,r_abs)
|
||||
if(theta.gt.pi.or.theta.lt.0.d0)then
|
||||
print*,'pb with theta, it should be in [0,pi]',theta
|
||||
print*,r
|
||||
endif
|
||||
if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
|
||||
print*,'pb with phi, it should be in [0,2 pi]',phi/pi
|
||||
print*,r
|
||||
endif
|
||||
|
||||
!!!!!!!!!!! Routines returning the Spherical harmonics on the grid point
|
||||
call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
|
||||
call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
|
||||
|
||||
!!!!!!!!!!! Integration of Y_l1,m1^*(r) Y_l2,m2(r)
|
||||
! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
|
||||
! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
|
||||
accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
|
||||
accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
|
||||
accu += weight
|
||||
enddo
|
||||
! Test that the sum of the weights is 4 pi
|
||||
if(dabs(accu - dfour_pi).gt.1.d-6)then
|
||||
print*,'Problem !! The sum of the Lebedev weight is not 4 pi ..'
|
||||
print*,accu
|
||||
stop
|
||||
endif
|
||||
! Test for the delta l1,l2 and delta m1,m2
|
||||
!
|
||||
! Test for the off-diagonal part of the Kronecker delta
|
||||
if(l1.ne.l2.or.m1.ne.m2)then
|
||||
if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
|
||||
print*,'pb OFF DIAG !!!!! '
|
||||
print*,'l1,m1,l2,m2',l1,m1,l2,m2
|
||||
print*,'accu_re = ',accu_re
|
||||
print*,'accu_im = ',accu_im
|
||||
endif
|
||||
endif
|
||||
! Test for the diagonal part of the Kronecker delta
|
||||
if(l1==l2.and.m1==m2)then
|
||||
if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
|
||||
print*,'pb DIAG !!!!! '
|
||||
print*,'l1,m1,l2,m2',l1,m1,l2,m2
|
||||
print*,'accu_re = ',accu_re
|
||||
print*,'accu_im = ',accu_im
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine test_cart
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! test for the cartesian --> spherical change of coordinates
|
||||
!
|
||||
! simple test such that the polar angle theta ranges in [0,pi]
|
||||
! test the routine "cartesian_to_spherical" such that the polar angle theta ranges in [0,pi]
|
||||
!
|
||||
! and the asymuthal angle phi ranges in [0,2pi]
|
||||
END_DOC
|
||||
@ -40,97 +123,18 @@ subroutine test_cart
|
||||
print*,phi/pi
|
||||
end
|
||||
|
||||
subroutine test_spher_harm
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! routine to test the spherical harmonics integration on a sphere with the grid.
|
||||
!
|
||||
! We test <Y_l1,m1|Y_l2,m2> = delta_m1,m2 delta_l1,l2
|
||||
END_DOC
|
||||
include 'constants.include.F'
|
||||
integer :: l1,m1,i,l2,m2,lmax
|
||||
double precision :: r(3),weight,accu_re, accu_im,accu
|
||||
double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
|
||||
l1 = 0
|
||||
m1 = 0
|
||||
l2 = 0
|
||||
m2 = 0
|
||||
lmax = 5
|
||||
do l1 = 0,lmax
|
||||
do m1 = -l1 ,l1
|
||||
do l2 = 0,lmax
|
||||
do m2 = -l2 ,l2
|
||||
accu_re = 0.d0
|
||||
accu_im = 0.d0
|
||||
! <l1,m1|l2,m2> = \int dOmega Y_l1,m1^* Y_l2,m2
|
||||
! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
|
||||
! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
|
||||
accu = 0.d0
|
||||
do i = 1, n_points_integration_angular
|
||||
double precision :: theta,phi,r_abs
|
||||
r(1:3) = angular_quadrature_points(i,1:3)
|
||||
weight = weights_angular_points(i)
|
||||
call cartesian_to_spherical(r,theta,phi,r_abs)
|
||||
if(theta.gt.pi.or.theta.lt.0.d0)then
|
||||
print*,'pb with theta',theta
|
||||
print*,r
|
||||
endif
|
||||
if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
|
||||
print*,'pb with phi',phi/pi
|
||||
print*,r
|
||||
endif
|
||||
call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
|
||||
call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
|
||||
accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
|
||||
accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
|
||||
accu += weight
|
||||
write(33,'(10(F16.10,X))')phi/pi
|
||||
enddo
|
||||
! Test for the delta l1,l2 and delta m1,m2
|
||||
if(l1.ne.l2.or.m1.ne.m2)then
|
||||
if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
|
||||
print*,'pb OFF DIAG !!!!! '
|
||||
print*,'l1,m1,l2,m2',l1,m1,l2,m2
|
||||
print*,'accu_re = ',accu_re
|
||||
print*,'accu_im = ',accu_im
|
||||
endif
|
||||
endif
|
||||
if(l1==l2.and.m1==m2)then
|
||||
if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
|
||||
print*,'pb DIAG !!!!! '
|
||||
print*,'l1,m1,l2,m2',l1,m1,l2,m2
|
||||
print*,'accu_re = ',accu_re
|
||||
print*,'accu_im = ',accu_im
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
double precision :: x,dx,xmax,xmin
|
||||
integer:: nx
|
||||
nx = 10000
|
||||
xmin = -5.d0
|
||||
xmax = 5.d0
|
||||
dx = (xmax - xmin)/dble(nx)
|
||||
x = xmin
|
||||
do i = 1, nx
|
||||
write(34,*)x,datan(x),dacos(x)
|
||||
x += dx
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine test_brutal_spheric
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
BEGIN_DOC
|
||||
! test for the <Y_l1,m1|Y_l2,m2> = delta_m1,m2 delta_l1,l2 using a two dimentional integration
|
||||
! Test for the <Y_l1,m1|Y_l2,m2> = delta_m1,m2 delta_l1,l2 using the following two dimentional integration
|
||||
!
|
||||
! \int_0^2pi d Phi \int_-1^+1 d(cos(Theta)) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
|
||||
!
|
||||
!= \int_0^2pi d Phi \int_0^pi dTheta sin(Theta) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
|
||||
!
|
||||
! Allows to test for the general functions spher_harm_func_m_pos with spher_harm_func_expl
|
||||
! Allows to test for the general functions "spher_harm_func_m_pos" with "spher_harm_func_expl"
|
||||
END_DOC
|
||||
integer :: itheta, iphi,ntheta,nphi
|
||||
double precision :: theta_min, theta_max, dtheta,theta
|
||||
@ -147,7 +151,7 @@ subroutine test_brutal_spheric
|
||||
dphi = (phi_max - phi_min)/dble(nphi)
|
||||
dtheta = (theta_max - theta_min)/dble(ntheta)
|
||||
|
||||
lmax = 3
|
||||
lmax = 2
|
||||
do l1 = 0,lmax
|
||||
do m1 = 0 ,l1
|
||||
do l2 = 0,lmax
|
||||
@ -196,7 +200,7 @@ end
|
||||
subroutine test_assoc_leg_pol
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
! Test for the associated Legendre Polynoms. The test is done through the orthogonality condition.
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
integer :: l1,m1,ngrid,i,l2,m2
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
program spher_harm
|
||||
implicit none
|
||||
call test_spher_harm
|
||||
! call test_spher_harm
|
||||
! call test_cart
|
||||
! call test_brutal_spheric
|
||||
call test_brutal_spheric
|
||||
end
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user