! Module contains the spherical harmonics up to l=5 m=-l,..,0,..,l listed on https://en.wikipedia.org/wiki/Table_of_spherical_harmonics from 19.07.2022 ! the functions are implementde by calling switch case function for given m or l value and return the corresdpondig value for given theta and phi ! the functions are split for diffrent l values and are named by P_lm. ! example for l=1 and m=-1 the realpart of the spherical harmonic for given theta and phi ! is returned by calling Re_Y_lm(1,-1,theta,phi) which itself calls the corresponding function P_1m(m,theta) and multilpies it by cos(m*phi) to account for the real part of exp(m*phi*i) ! Attention the legendre polynoms are shifted to account for the missing zero order term in spherical harmonic expansions module sphericalharmonics_mod use accuracy_constants, only: dp, idp implicit none real(kind=dp), parameter :: PI = 4.0_dp * atan( 1.0_dp ) contains !---------------------------------------------------------------------------------------------------- function Y_lm( l , m , theta , phi ) result( y ) integer(kind=idp), intent( in ) :: l , m real(kind=dp), intent( in ) :: theta , phi real(kind=dp) y character(len=70) :: errmesg select case ( l ) case (1) y = Y_1m( m , theta , phi ) case (2) y = Y_2m( m , theta , phi ) case (3) y = Y_3m( m , theta , phi ) case (4) y = Y_4m( m , theta , phi ) case (5) y = Y_5m( m , theta , phi ) case default write(errmesg,'(A,i0)')& &'order of spherical harmonics not implemented', l error stop 'error in spherical harmonics' !error stop errmesg end select end function Y_lm !---------------------------------------------------------------------------------------------------- function Re_Y_lm( l , m , theta , phi ) result( y ) integer(kind=idp), intent( in ) :: l , m real(kind=dp), intent( in ) :: theta , phi real(kind=dp) y character(len=70) :: errmesg select case ( l ) case (1) y = P_1m( m , theta ) * cos(m*phi) case (2) y = P_2m( m , theta ) * cos(m*phi) case (3) y = P_3m( m , theta ) * cos(m*phi) case (4) y = P_4m( m , theta ) * cos(m*phi) case (5) y = P_5m( m , theta ) * cos(m*phi) case (6) y = P_6m( m , theta ) * cos(m*phi) case default write(errmesg,'(A,i0)')& &'order of spherical harmonics not implemented', l error stop 'error in spherical harmonics' !error stop errmesg end select end function Re_Y_lm !---------------------------------------------------------------------------------------------------- function Im_Y_lm( l , m , theta , phi ) result( y ) integer(kind=idp), intent( in ) :: l , m real(kind=dp), intent( in ) :: theta , phi real(kind=dp) y character(len=70) :: errmesg select case ( l ) case (1) y = P_1m( m , theta ) * sin(m*phi) case (2) y = P_2m( m , theta ) * sin(m*phi) case (3) y = P_3m( m , theta ) * sin(m*phi) case (4) y = P_4m( m , theta ) * sin(m*phi) case (5) y = P_5m( m , theta ) * sin(m*phi) case (6) y = P_6m( m , theta ) * sin(m*phi) case default write(errmesg,'(a,i0)')& &'order of spherical harmonics not implemented',l error stop 'error in spherical harmonics' !error stop errmesg end select end function Im_Y_lm !---------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------- function Y_1m( m , theta , phi ) result( y ) integer(kind=idp),intent( in ):: m real(kind=dp),intent( in ):: theta , phi real(kind=dp) y character(len=70) :: errmesg select case ( m ) case (-1) y = 0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)*cos(phi) case (0) y = 0.5_dp*sqrt(3.0_dp/PI)*cos(theta) case (1) y = -0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)*cos(phi) case default write(errmesg,'(a,i0)') 'in y_1m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function Y_1m !---------------------------------------------------------------------------------------------------- function Y_2m(m,theta,phi) result(y) integer(kind=idp),intent(in):: m real(kind=dp),intent(in):: theta,phi real(kind=dp) y character(len=70) :: errmesg select case (m) case (-2) y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)**2*cos(2.0_dp*phi) case (-1) y=0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)*cos(theta)*cos(phi) case (0) y=0.25_dp*sqrt(5.0_dp/PI)& &*(3.0_dp*cos(theta)**2-1.0_dp) case (1) y=-0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)*cos(theta)*cos(phi) case (2) y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)**2*cos(2.0_dp*phi) case default write(errmesg,'(A,i0)')'in y_2m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function Y_2m !---------------------------------------------------------------------------------------------------- function Y_3m(m,theta,phi) result(y) integer(kind=idp), intent(in) :: m real(kind=dp), intent(in) :: theta,phi real(kind=dp) y character(len=70) :: errmesg select case (m) case (-3) y=0.125_dp*sqrt(35.0_dp/PI)& &*sin(theta)**3*cos(3.0_dp*phi) case (-2) y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))& &*sin(theta)**2*cos(theta)*cos(2.0_dp*phi) case (-1) y=0.125_dp*sqrt(21.0_dp/(PI))& &*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)*cos(phi) case (0) y=0.25_dp*sqrt(7.0_dp/PI)& &*(5.0_dp*cos(theta)**3-3.0_dp*cos(theta)) case (1) y=-0.125_dp*sqrt(21.0_dp/(PI))& &*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)*cos(phi) case (2) y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))& &*sin(theta)**2*cos(theta)*cos(2.0_dp*phi) case (3) y=-0.125_dp*sqrt(35.0_dp/PI)& &*sin(theta)**3*cos(3.0_dp*phi) case default write(errmesg,'(A,i0)')'in y_3m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function Y_3m !---------------------------------------------------------------------------------------------------- function Y_4m(m,theta,phi) result(y) integer(kind=idp), intent(in) :: m real(kind=dp), intent(in) :: theta,phi real(kind=dp) y character(len=70) :: errmesg select case (m) case (-4) y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)& &*sin(theta)**4*cos(4.0_dp*phi) case (-3) y=0.375_dp*sqrt(35.0_dp/PI)& &*sin(theta)**3*cos(theta)*cos(3.0_dp*phi) case (-2) y=0.375_dp*sqrt(5.0_dp/(PI*2.0_dp))& &*sin(theta)**2& &*(7.0_dp*cos(theta)**2-1)*cos(2.0_dp*phi) case (-1) y=0.375_dp*sqrt(5.0_dp/(PI))& &*sin(theta)*(7.0_dp*cos(theta)**3& &-3.0_dp*cos(theta))*cos(phi) case (0) y=(3.0_dp/16.0_dp)/sqrt(PI)& &*(35.0_dp*cos(theta)**4& &-30.0_dp*cos(theta)**2+3.0_dp) case (1) y=-0.375_dp*sqrt(5.0_dp/(PI))& &*sin(theta)*(7.0_dp*cos(theta)**3& &-3.0_dp*cos(theta))*cos(phi) case (2) y=0.375_dp*sqrt(5.0_dp/(PI*2.0_dp))& &*sin(theta)**2*(7.0_dp*cos(theta)**2-1.0_dp)& &*cos(2*phi) case (3) y=-0.375_dp*sqrt(35.0_dp/PI)& &*sin(theta)**3*cos(theta)*cos(3.0_dp*phi) case (4) y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)& &*sin(theta)**4*cos(4.0_dp*phi) case default write(errmesg,'(a,i0)')'in y_4m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function Y_4m !---------------------------------------------------------------------------------------------------- function Y_5m(m,theta,phi) result(y) integer(kind=idp), intent(in) :: m real(kind=dp), intent(in) :: theta,phi real(kind=dp) y character(len=70) :: errmesg select case (m) case (-5) y=(3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)& &*sin(theta)**5*cos(5*phi) case (-4) y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)& &*sin(theta)**4*cos(theta)*cos(4*phi) case (-3) y=(1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)& &*sin(theta)**3*(9*cos(theta)**2-1.0_dp)*cos(3*phi) case (-2) y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))& &*sin(theta)**2*(3*cos(theta)**3-cos(theta))*cos(2*phi) case (-1) y=(1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))& &*sin(theta)*(21.0_dp*cos(theta)**4& &-14.0_dp*cos(theta)**2+1.0_dp)*cos(phi) case (0) y=(1.0_dp/16.0_dp)/sqrt(11.0_dp/PI)& &*(63.0_dp*cos(theta)**5-70.0_dp*cos(theta)**3& &+15.0_dp*cos(theta)) case (1) y=(-1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))& &*sin(theta)*(21.0_dp*cos(theta)**4& &-14.0_dp*cos(theta)**2+1.0_dp)*cos(phi) case (2) y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))& &*sin(theta)**2*(3*cos(theta)**3-cos(theta))*cos(2*phi) case (3) y=(-1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)& &*sin(theta)**3*(9.0_dp*cos(theta)**2-1.0_dp)& &*cos(3.0_dp*phi) case (4) y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)& &*sin(theta)**4*cos(theta)*cos(4.0_dp*phi) case (5) y=(-3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)& &*sin(theta)**5*cos(5.0_dp*phi) case default write(errmesg,'(A,i0)')'in y_5m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function Y_5m !---------------------------------------------------------------------------------------------------- function P_1m( m , theta ) result( y ) ! >Function returns the value of the corresponding normalized Associated legendre polynom for l=1 and given m and theta integer(kind=idp),intent( in ):: m real(kind=dp),intent( in ):: theta real(kind=dp) y character(len=70) :: errmesg select case ( m ) case (-1) y = 0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta) case (0) y = 0.5_dp*sqrt(3.0_dp/PI)*(cos(theta)-1.0_dp) ! -1 is subtracted to shift so that for theta=0 y=0 case (1) y = -0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta) case default write(errmesg,'(A,i0)')'in p_1m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function P_1m !---------------------------------------------------------------------------------------------------- function P_2m( m , theta ) result( y ) ! >Function returns the value of the corresponding normalized Associated legendre polynom for l=2 and given m and theta integer(kind=idp),intent(in):: m real(kind=dp),intent(in):: theta real(kind=dp) y character(len=70) :: errmesg select case ( m ) case (-2) y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)**2 case (-1) y=0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)*cos(theta) case (0) y = (3.0_dp*cos(theta)**2-1.0_dp) y = y - 2.0_dp !2.0 is subtracted to shift so that for theta=0 y=0 y = y * 0.25_dp*sqrt(5.0_dp/PI) ! normalize case (1) y = -0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)*cos(theta) case (2) y = 0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))& &*sin(theta)**2 case default write(errmesg,'(A,i0)')'in p_2m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function P_2m !---------------------------------------------------------------------------------------------------- function P_3m( m , theta ) result( y ) ! >Function returns the value of the corresponding normalized Associated legendre polynom for l=3 and given m and theta integer(kind=idp), intent(in) :: m real(kind=dp), intent(in) :: theta real(kind=dp) y character(len=70) :: errmesg select case ( m ) case (-3) y=0.125_dp*sqrt(35.0_dp/PI)& &*sin(theta)**3 case (-2) y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))& &*sin(theta)**2*cos(theta) case (-1) y=0.125_dp*sqrt(21.0_dp/(PI))& &*sin(theta)*(5*cos(theta)**2-1.0_dp) case (0) y=(5.0_dp*cos(theta)**3-3*cos(theta)) y=y-2.0_dp ! 2.0 is subtracted to shift so that for theta=0 y=0 y=y*0.25_dp*sqrt(7.0_dp/PI) ! normalize case (1) y=-0.125_dp*sqrt(21.0_dp/(PI))& &*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp) case (2) y=0.25*sqrt(105.0_dp/(PI*2.0_dp))& &*sin(theta)**2*cos(theta) case (3) y=-0.125*sqrt(35.0_dp/PI)& &*sin(theta)**3 case default write(errmesg,'(A,i0)')'in p_3m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function P_3m !---------------------------------------------------------------------------------------------------- function P_4m(m,theta) result(y) ! >Function returns the value of the corresponding normalized Associated legendre polynom for l=4 and given m and theta integer(kind=idp), intent(in) :: m real(kind=dp), intent(in) :: theta real(kind=dp) y character(len=70) :: errmesg select case ( m ) case (-4) y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)& &*sin(theta)**4 case (-3) y=0.375*sqrt(35.0_dp/PI)& &*sin(theta)**3*cos(theta) case (-2) y=0.375*sqrt(5.0_dp/(PI*2.0_dp))& &*sin(theta)**2*(7*cos(theta)**2-1) case (-1) y=0.375*sqrt(5.0_dp/(PI))& &*sin(theta)*(7*cos(theta)**3-3*cos(theta)) case (0) y=(35*cos(theta)**4-30*cos(theta)**2+3) y = y - 8.0_dp !8.0 is subtracted to shift so that for theta=0 y=0 y = y * (3.0_dp/16.0_dp)/sqrt(PI) case (1) y=-0.375*sqrt(5.0_dp/(PI))& &*sin(theta)*(7*cos(theta)**3-3*cos(theta)) case (2) y=0.375*sqrt(5.0_dp/(PI*2.0_dp))& &*sin(theta)**2*(7*cos(theta)**2-1) case (3) y=-0.375*sqrt(35.0_dp/PI)& &*sin(theta)**3*cos(theta) case (4) y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)& &*sin(theta)**4 case default write(errmesg,'(A,i0)')'in p_4m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function P_4m !---------------------------------------------------------------------------------------------------- function P_5m(m,theta) result(y) ! >Function returns the value of the corresponding normalized Associated legendre polynom for l=5 and given m and theta integer(kind=idp), intent(in) :: m real(kind=dp), intent(in) :: theta real(kind=dp) y character(len=70) :: errmesg select case ( m ) case (-5) y=(3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)& &*sin(theta)**5 case (-4) y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)& &*sin(theta)**4*cos(theta) case (-3) y=(1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)& &*sin(theta)**3*(9*cos(theta)**2-1.0_dp) case (-2) y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))& &*sin(theta)**2*(3*cos(theta)**3-cos(theta)) case (-1) y=(1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))& &*sin(theta)*(21*cos(theta)**4-14*cos(theta)**2+1) case (0) y = (63*cos(theta)**5-70*cos(theta)**3+15*cos(theta)) y = y - 8.0_dp !8.0 is subtracted to shift so that for theta=0 y=0 y = y * (1.0_dp/16.0_dp)/sqrt(11.0_dp/PI) case (1) y=(-1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))& &*sin(theta)*(21*cos(theta)**4-14*cos(theta)**2+1) case (2) y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))& &*sin(theta)**2*(3*cos(theta)**3-cos(theta)) case (3) y=(-1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)& &*sin(theta)**3*(9*cos(theta)**2-1.0_dp) case (4) y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)& &*sin(theta)**4*cos(theta) case (5) y=(-3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)& &*sin(theta)**5 case default write(errmesg,'(A,i0)')'in p_5m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function P_5m !---------------------------------------------------------------------------------------------------- function P_6m(m,theta) result(y) ! >Function returns the value of the corresponding normalized Associated legendre polynom for l=6 and given m and theta integer(kind=idp), intent(in) :: m real(kind=dp), intent(in) :: theta real(kind=dp):: y character(len=70) :: errmesg select case ( m ) case (-6) y = (1.0_dp/64.0_dp)*sqrt(3003.0_dp/PI)& &* sin(theta)**6 case (-5) y = (3.0_dp/32.0_dp)*sqrt(1001.0_dp/PI)& &* sin(theta)**5& &* cos(theta) case (-4) y= (3.0_dp/32.0_dp)*sqrt(91.0_dp/(2.0_dp*PI))& &* sin(theta)**4& &* (11*cos(theta)**2 - 1 ) case (-3) y= (1.0_dp/32.0_dp)*sqrt(1365.0_dp/PI)& &* sin(theta)**3& &* (11*cos(theta)**3 - 3*cos(theta) ) case (-2) y= (1.0_dp/64.0_dp)*sqrt(1365.0_dp/PI)& &* sin(theta)**2& &* (33*cos(theta)**4 - 18*cos(theta)**2 + 1 ) case (-1) y= (1.0_dp/16.0_dp)*sqrt(273.0_dp/(2.0_dp*PI))& &* sin(theta)& &* (33*cos(theta)**5 - 30*cos(theta)**3 + 5*cos(theta) ) case (0) y = 231*cos(theta)**6 - 315*cos(theta)**4 + 105*cos(theta)**2-5 y = y - 16.0_dp !16.0 is subtracted to shift so that for theta=0 y=0 y = y * (1.0_dp/32.0_dp)*sqrt(13.0_dp/PI) case (1) y= -(1.0_dp/16.0_dp)*sqrt(273.0_dp/(2.0_dp*PI))& &* sin(theta)& &* (33*cos(theta)**5 - 30*cos(theta)**3 + 5*cos(theta) ) case (2) y= (1.0_dp/64.0_dp)*sqrt(1365.0_dp/PI)& &* sin(theta)**2& &* (33*cos(theta)**4 - 18*cos(theta)**2 + 1 ) case (3) y= -(1.0_dp/32.0_dp)*sqrt(1365.0_dp/PI)& &* sin(theta)**3& &* (11*cos(theta)**3 - 3*cos(theta) ) case (4) y= (3.0_dp/32.0_dp)*sqrt(91.0_dp/(2.0_dp*PI))& &* sin(theta)**4& &* (11*cos(theta)**2 - 1 ) case (5) y= -(3.0_dp/32.0_dp)*sqrt(1001.0_dp/PI)& &* sin(theta)**5 * cos(theta) case (6) y = (1.0_dp/64.0_dp)*sqrt(3003.0_dp/PI)& &* sin(theta)**6 case default write(errmesg,'(A,i0)')'in p_6m given m not logic, ', m error stop 'error in spherical harmonics' !error stop errmesg end select end function P_6m !---------------------------------------------------------------------------------------------------- end module