64-BitBrainstorm_2026/AMSS-NCKU
8
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

asc26 amss-ncku initialized

Browse Source
This commit is contained in:
CGH0S7
2026-01-13 15:01:15 +08:00
commit f2fc9af70e
272 changed files with 262274 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

688
AMSS_NCKU_source/NullNews.f90 Normal file
View File

@@ -0,0 +1,688 @@
#include "macrodef.fh"
!------------------------------------------------------------------------------
function omega_rhs(ex,crho,sigma,R,omega,RU,IU,omegarhs, &
quR1,quR2,quI1,quI2,gR,gI) result(gont)
implicit none
integer,intent(in) :: ex(3)
real*8,intent(in),dimension(ex(1))::crho
real*8,intent(in),dimension(ex(2))::sigma
real*8,intent(in),dimension(ex(3))::R
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: omega,RU,IU
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: omegarhs
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI
! gont = 0: success; gont = 1: something wrong
integer::gont
double complex, dimension(ex(1),ex(2),ex(3)) :: comega,eth_omega,U,eth_Ub
real*8 :: dR
integer :: k
!!! sanity check
dR = sum(omega)+sum(RU)+sum(IU)
if(dR.ne.dR) then
if(sum(omega).ne.sum(omega))write(*,*)"NullEvol_beta: find NaN in omega"
if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_beta: find NaN in RU"
if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_beta: find NaN in IU"
gont = 1
return
endif
comega = dcmplx(omega,0.d0)
U = dcmplx(RU,IU)
do k=1,ex(3)
call derivs_eth(ex(1:2),crho,sigma,comega(:,:,k),eth_omega(:,:,k),0,1, &
quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k))
call derivs_eth(ex(1:2),crho,sigma,U(:,:,k),eth_Ub(:,:,k),1,-1, &
quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k))
enddo
!!! The term * e^{-2beta} has been added so as to be consistent with HPN. Nigel
!omega_u = - dble(eth_omega * conjg(U) + 0.5d0 * omega * eth_Ub * exp(-2*beta))
!!! - update .. I thought this may have been wrong so I removed the
!!! e^{-2beta} for testing. Yosef
! omegarhs = - dreal(eth_omega * dconjg(U) + 0.5d0 * omega * eth_Ub)
omegarhs = - 0.5d0*dreal(eth_Ub)
gont = 0
return
end function omega_rhs
!---------------------------------------------------------------------------------------------------------
subroutine drive_null_news(ex,crho,sigma,R,RJ,IJ,RU,IU,RTheta,ITheta,omega,beta, &
qlR1,qlR2,qlI1,qlI2, &
quR1,quR2,quI1,quI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,RNews,INews,Rmin,sst)
implicit none
integer,intent(in) :: ex(3),sst
real*8,intent(in) :: Rmin
real*8,intent(in),dimension(ex(1))::crho
real*8,intent(in),dimension(ex(2))::sigma
real*8,intent(in),dimension(ex(3))::R
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RTheta,ITheta,omega,beta
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: qlR1,qlR2,qlI1,qlI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dquR1,dquR2,dquI1,dquI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dgR,dgI,bdgR,bdgI
integer :: i,j,k
double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,U,J_u,J_l,J_l_u,News
#if 0
call get_fake_Ju(ex,crho,sigma,R,RTheta,ITheta, &
quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst)
#endif
CJ = dcmplx(RJ,IJ)
U = dcmplx(RU,IU)
J_u = dcmplx(RTheta,ITheta)
do j=1,ex(2)
do i=1,ex(1)
call cderivs_x(ex(3),R,CJ(i,j,:),J_l(i,j,:))
call cderivs_x(ex(3),R,J_u(i,j,:),J_l_u(i,j,:))
J_l(i,j,:) = -J_l(i,j,:)*Rmin*R**2
J_l_u(i,j,:) = -J_l_u(i,j,:)*Rmin*R**2
enddo
enddo
#if 0
if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then
call get_exact_Jul(ex,crho,sigma,R,RNews,INews, &
quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst)
write(*,*) J_u(ex(1)/2,ex(2)/2,ex(3)-1),J_u(ex(1)/2,ex(2)/2,ex(3))
write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3))
write(*,*) J_l_u(ex(1)/2,ex(2)/2,ex(3))
write(*,*)dcmplx(RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)))/J_l_u(ex(1)/2,ex(2)/2,ex(3))
endif
stop
#endif
do k=1,ex(3)
call get_null_news(ex(1:2),crho,sigma,CJ(:,:,k),U(:,:,k),J_u(:,:,k),J_l(:,:,k),J_l_u(:,:,k),omega(:,:,k),beta(:,:,k), &
qlR1(:,:,k),qlR2(:,:,k),qlI1(:,:,k),qlI2(:,:,k), &
quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k), &
gR(:,:,k),gI(:,:,k), &
dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), &
bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), &
dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k),News(:,:,k))
enddo
RNews = dreal(News)
INews = dimag(News)
#if 0
if(sst ==0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then
call get_exact_eth2omega(ex,crho,sigma,R,RNews,INews, &
quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst)
write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3))
endif
stop
#endif
#if 0
! check orthornormality
RNews = RJ
INews = IJ
RNews = 0.5d0*dreal(J_l_u)
INews = 0.5d0*dimag(J_l_u)
#endif
call six2spher(ex,crho,sigma,R,RNews,INews,2,Rmin,sst)
return
end subroutine drive_null_news
!---------------------------------------------------------------------------------------------------------
subroutine drive_null_news_diff(ex,crho,sigma,R,RJ,IJ,RU,IU,RTheta,ITheta,omega,beta, &
qlR1,qlR2,qlI1,qlI2, &
quR1,quR2,quI1,quI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,RNews,INews,Rmin,sst,Time)
implicit none
integer,intent(in) :: ex(3),sst
real*8,intent(in) :: Rmin,Time
real*8,intent(in),dimension(ex(1))::crho
real*8,intent(in),dimension(ex(2))::sigma
real*8,intent(in),dimension(ex(3))::R
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RTheta,ITheta,omega,beta
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: qlR1,qlR2,qlI1,qlI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dquR1,dquR2,dquI1,dquI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dgR,dgI,bdgR,bdgI
integer :: i,j,k
double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,U,J_u,J_l,J_l_u,News
#if 0
call get_fake_Ju(ex,crho,sigma,R,RTheta,ITheta, &
quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst)
#endif
CJ = dcmplx(RJ,IJ)
U = dcmplx(RU,IU)
J_u = dcmplx(RTheta,ITheta)
do j=1,ex(2)
do i=1,ex(1)
call cderivs_x(ex(3),R,CJ(i,j,:),J_l(i,j,:))
call cderivs_x(ex(3),R,J_u(i,j,:),J_l_u(i,j,:))
J_l(i,j,:) = -J_l(i,j,:)*Rmin*R**2
J_l_u(i,j,:) = -J_l_u(i,j,:)*Rmin*R**2
enddo
enddo
#if 0
if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then
call get_exact_Jul(ex,crho,sigma,R,RNews,INews, &
quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst)
write(*,*) J_u(ex(1)/2,ex(2)/2,ex(3)-1),J_u(ex(1)/2,ex(2)/2,ex(3))
write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3))
write(*,*) J_l_u(ex(1)/2,ex(2)/2,ex(3))
write(*,*)dcmplx(RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)))/J_l_u(ex(1)/2,ex(2)/2,ex(3))
endif
stop
#endif
do k=1,ex(3)
call get_null_news(ex(1:2),crho,sigma,CJ(:,:,k),U(:,:,k),J_u(:,:,k),J_l(:,:,k),J_l_u(:,:,k),omega(:,:,k),beta(:,:,k), &
qlR1(:,:,k),qlR2(:,:,k),qlI1(:,:,k),qlI2(:,:,k), &
quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k), &
gR(:,:,k),gI(:,:,k), &
dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), &
bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), &
dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k),News(:,:,k))
enddo
call get_exact_news(ex,crho,sigma,R,RNews,INews,sst,Rmin,Time)
RNews = dreal(News) - Rnews
INews = dimag(News) - INews
!this part is nonsence
RNews(:,:,1:ex(3)-1) = 0.d0
INews(:,:,1:ex(3)-1) = 0.d0
#if 0
if(sst ==0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then
call get_exact_eth2omega(ex,crho,sigma,R,RNews,INews, &
quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst)
write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3))
endif
stop
#endif
#if 0
! check orthornormality
RNews = RJ
INews = IJ
RNews = 0.5d0*dreal(J_l_u)
INews = 0.5d0*dimag(J_l_u)
#endif
call six2spher(ex,crho,sigma,R,RNews,INews,2,Rmin,sst)
return
end subroutine drive_null_news_diff
!------------------------------------------------------------------------------------------------------------
subroutine get_null_news(ex,crho,sigma,J,U,J_u,J_l,J_l_u,omega,beta, &
qlR1,qlR2,qlI1,qlI2, &
quR1,quR2,quI1,quI2, &
gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI,News)
implicit none
integer,intent(in) :: ex(2)
real*8,intent(in),dimension(ex(1))::crho
real*8,intent(in),dimension(ex(2))::sigma
double complex,dimension(ex(1),ex(2)),intent(in) :: J,U
double complex,dimension(ex(1),ex(2)),intent(in) :: J_u,J_l,J_l_u
real*8,dimension(ex(1),ex(2)),intent(in) :: omega,beta
real*8,dimension(ex(1),ex(2)),intent(in) :: qlR1,qlR2,qlI1,qlI2
real*8,dimension(ex(1),ex(2)),intent(in) :: quR1,quR2,quI1,quI2
real*8,dimension(ex(1),ex(2)),intent(in) :: gR,gI
real*8,dimension(ex(1),ex(2)),intent(in) :: dquR1,dquR2,dquI1,dquI2
real*8,dimension(ex(1),ex(2)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2
real*8,dimension(ex(1),ex(2)),intent(in) :: dgR,dgI,bdgR,bdgI
double complex,dimension(ex(1),ex(2)),intent(out) :: News
! local variables
real*8,dimension(ex(1),ex(2)) :: K,K_u,K_l,K_l_u
real*8,dimension(ex(1),ex(2)) :: a
double complex,dimension(ex(1),ex(2)) :: Comega,Cbeta
double complex,dimension(ex(1),ex(2)) :: Jb,Ub
double complex,dimension(ex(1),ex(2)) :: eth_a,eth2_a,eth_ethb_a
double complex,dimension(ex(1),ex(2)) :: s1,s2,s3,s4,s5
double complex,dimension(ex(1),ex(2)) :: eth_U,ethb_U,eth_J,ethb_J
double complex,dimension(ex(1),ex(2)) :: eth_J_l,ethb_J_l,eth_K_l,eth_K
double complex,dimension(ex(1),ex(2)) :: eth_omega,eth_beta
double complex,dimension(ex(1),ex(2)) :: eth2_omega,eth2_beta
double complex,dimension(ex(1),ex(2)) :: eth_ethb_omega,eth_ethb_beta
Comega = dcmplx(omega,0.d0)
Cbeta = dcmplx(beta,0.d0)
call derivs_eth(ex,crho,sigma,Comega,eth_omega,0,1,quR1,quR2,quI1,quI2,gR,gI)
call derivs_eth(ex,crho,sigma,Cbeta,eth_beta,0,1,quR1,quR2,quI1,quI2,gR,gI)
call dderivs_eth(ex,crho,sigma,Comega,eth2_omega,0,1,1, &
quR1,quR2,quI1,quI2,gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI)
call dderivs_eth(ex,crho,sigma,Cbeta,eth2_beta,0,1,1, &
quR1,quR2,quI1,quI2,gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI)
call dderivs_eth(ex,crho,sigma,Comega,eth_ethb_omega,0,-1,1, &
quR1,quR2,quI1,quI2,gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI)
call dderivs_eth(ex,crho,sigma,Cbeta,eth_ethb_beta,0,-1,1, &
quR1,quR2,quI1,quI2,gR,gI, &
dquR1,dquR2,dquI1,dquI2, &
bdquR1,bdquR2,bdquI1,bdquI2, &
dgR,dgI,bdgR,bdgI)
call derivs_eth(ex,crho,sigma,U,eth_U,1,1,quR1,quR2,quI1,quI2,gR,gI)
call derivs_eth(ex,crho,sigma,U,ethb_U,1,-1,quR1,quR2,quI1,quI2,gR,gI)
call derivs_eth(ex,crho,sigma,J,eth_J,2,1,quR1,quR2,quI1,quI2,gR,gI)
call derivs_eth(ex,crho,sigma,J,ethb_J,2,-1,quR1,quR2,quI1,quI2,gR,gI)
call derivs_eth(ex,crho,sigma,J_l,eth_J_l,2,1,quR1,quR2,quI1,quI2,gR,gI)
call derivs_eth(ex,crho,sigma,J_l,ethb_J_l,2,-1,quR1,quR2,quI1,quI2,gR,gI)
Jb = dconjg(J)
Ub = dconjg(U)
K = dsqrt(1.0d0 + cdabs(J)**2)
! temp storage
Comega=dcmplx(K,0.d0)
call derivs_eth(ex,crho,sigma,Comega,eth_K,0,1,quR1,quR2,quI1,quI2,gR,gI)
K_u = dreal( J_u * Jb ) / K
K_l = dreal( J_l * Jb ) / K
! temp storage
Comega=dcmplx(K_l,0.d0)
call derivs_eth(ex,crho,sigma,Comega,eth_K_l,0,1,quR1,quR2,quI1,quI2,gR,gI)
K_l_u = dreal( J_u * dconjg(J_l) + J_l_u * Jb )/ K - K_l * K_u / K
a = omega * dexp(2.0d0 * beta)
eth_a = dexp(2.0d0 * beta) * ( eth_omega + 2.0d0 * omega * eth_beta )
eth2_a = dexp(2.0d0 * beta) * ( 4.0d0 * eth_beta * eth_omega &
+ 4.0d0 * omega * eth_beta**2 &
+ eth2_omega + 2.0d0 * omega * eth2_beta )
eth_ethb_a = dexp(2.0d0 * beta) * ( 4.0d0 * dreal(eth_beta * dconjg(eth_omega)) &
+ 4.0d0 * omega * eth_beta * dconjg(eth_beta) &
+ eth_ethb_omega + 2.0d0 * omega * eth_ethb_beta )
s1 = ( -2.0d0 * K_l_u * J * (K + 1.0d0) + J_l_u * (K + 1.0d0)**2 &
+ dconjg(J_l_u) * J**2 ) / (K + 1.0d0)
s2 = 0.5d0 / ( K + 1.0d0) * ( &
(K + 1.0d0)* (eth_J_l *Ub * (K+1.0d0) - 2.0d0* eth_K_l * J *Ub ) &
+ eth_U * (K+1.0d0)* ( -2.0d0 * J * dconjg(J_l) + K_l * 2.0d0 * (K+1.0d0) ) &
+ dconjg(ethb_U) * (K+1.0d0) * ( -2.0d0* J * K_l + J_l * 2.0d0 * (K+1.0d0) ) &
+ ethb_J_l * U * (K+1.0d0)**2 - dconjg(eth_K_l) * 2.0d0 * U * J * (K+1.0d0) &
+ ethb_U * 2.0d0 * J * ( J * dconjg(J_l) - (K+1.0d0) * K_l) &
+ J**2 * ( U * dconjg(eth_J_l) + dconjg(ethb_J_l * U) ) &
+ J * 2.0d0 * dconjg(eth_U) * ( J * K_l - J_l * (K+1.0d0) ) )
s3 = ( J_l * (K + 1.0d0)**2 -2.0d0 * K_l * J * (K + 1.0d0) &
+ dconjg(J_l) * J**2) / (K + 1.0d0)
s4 = 0.5d0 / ( K + 1.0d0) * ( eth_a * eth_omega * (K + 1.0d0)**2 &
- (K+1.0d0) * J * 2.0d0* dreal( eth_a * dconjg(eth_omega) ) &
+ J**2 * dconjg(eth_a * eth_omega) )
s5 = 0.25d0 / ( K + 1.0d0) * ( 2.0d0 * eth2_a * (K+1.0d0)**2 &
+ 2.0d0 * J**2 * dconjg(eth2_a) &
- 4.0d0 * eth_ethb_a * J * (K+1.0d0) &
+ Jb * eth_a * eth_J* (K+1.0d0)**2 &
+ J * eth_a * dconjg(ethb_J) * (K+1.0d0)**2 &
- eth_a * eth_K * 2.0d0 * (K+1.0d0) * ( J*Jb + (K+1.0d0) ) &
+ eth_a * ethb_J * (K+1.0d0) * ( -J*Jb + (K+1.0d0) ) &
- J**2 * eth_a * dconjg(eth_J) * K &
+ J**2 * Jb * 2.0d0* eth_a * dconjg(eth_K) &
- dconjg(eth_a) * eth_J * (K+1.0d0) * ( J*Jb + K+1.0d0 ) &
- dconjg(ethb_J) * dconjg(eth_a) * J**2 * ( K + 2.0d0) &
+ J * 2.0d0 * (K+1.0d0)**2 * eth_K * dconjg(eth_a) &
+ J**2 * Jb * ethb_J * dconjg(eth_a) &
+ J**3 * dconjg(eth_a * eth_J) &
- 2.0d0* J**2 *K*dconjg(eth_K * eth_a) )
! News = 0.25d0 * ( s1 + s2 + 0.5d0 * dble(ethb_U) * s3 &
! - 4.0d0 * s4 / omega**2 + 2.0d0 * s5 / omega ) / ( omega**2 * exp(2.0d0 * beta) )
! change sign of s3 to compensate for a bug in Eqs. 30, 37, and 38 of
! HPN
#if 1
News = 0.25d0 * ( s1 + s2 - 0.5d0 * dreal(ethb_U) * s3 &
- 4.0d0 * s4 / omega**2 + 2.0d0 * s5 / omega ) / ( omega**2 * dexp(2.0d0 * beta) )
#else
#if 0
if(crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then
write(*,*) eth2_omega(ex(1)/2,ex(2)/2)
endif
#endif
News = 0.5d0*J_l_u+eth2_beta+0.5d0*eth2_omega ! if given omega error is about 6e-9
! News = 0.5d0*J_l_u+eth2_beta-1.5d0*J ! error is about 6e-9
#endif
return
end subroutine get_null_news
!--------------------------------------------------------------------------------------------------
! change spin weighted function from 6 patches to spherical coordinate
subroutine six2spher(ex,crho,sigma,R,RU,IU,spin,Rmin,sst)
implicit none
!~~~~~~% Input parameters:
integer,intent(in) :: ex(3),sst,spin
real*8,intent(in) :: Rmin
double precision,intent(in),dimension(ex(1))::crho
double precision,intent(in),dimension(ex(2))::sigma
double precision,intent(in),dimension(ex(3))::R
real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: RU,IU
integer :: i,j,k
real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf
double complex :: II,swtf,ff
II = dcmplx(0.d0,1.d0)
hgr = 1.d0
do i=1,ex(1)
do j=1,ex(2)
do k=1,ex(3)
! hgr = R(k)*Rmin/(1.d0-R(k)) R is not invovled indeed, to avoid NaN, we set
! it to 1 above
tgrho = dtan(crho(i))
tgsigma = dtan(sigma(j))
tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0)
ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0)
select case (sst)
case (0)
z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = z*tgrho
y = z*tgsigma
case (1)
z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = z*tgrho
y = z*tgsigma
case (2)
x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
y = x*tgrho
z = x*tgsigma
case (3)
x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
y = x*tgrho
z = x*tgsigma
case (4)
y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = y*tgrho
z = y*tgsigma
case (5)
y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = y*tgrho
z = y*tgsigma
case default
write(*,*) "six2spher: not recognized sst = ",sst
return
end select
gt = dacos(z/hgr)
gp = datan2(y,x)
swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j))
if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf)
select case (sst)
case (0,1)
swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2)
case (2,3)
swtf = II*swtf*dsin(gt)
case (4,5)
swtf = -II*swtf*dsin(gt)
end select
ff=dcmplx(RU(i,j,k),IU(i,j,k))/swtf**spin
RU(i,j,k) = dreal(ff)
IU(i,j,k) = dimag(ff)
enddo
enddo
enddo
return
end subroutine six2spher
!-------------------------------------------------------------
! Linear wave given in Eq.(27) of CQG 22, 2393 (2005)
!-------------------------------------------------------------
subroutine get_exact_omega(ex,crho,sigma,R,omega,sst,Rmin,T)
implicit none
! argument variables
integer, intent(in ):: ex(1:3),sst
real*8,intent(in) :: Rmin,T
double precision,intent(in),dimension(ex(1))::crho
double precision,intent(in),dimension(ex(2))::sigma
double precision,intent(in),dimension(ex(3))::R
real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::omega
integer :: i,j,k
real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts
double complex :: Yslm,II,Jr
double complex :: beta0,C1,C2
integer :: nu,m
double complex :: swtf,ff
call initial_null_paramter(beta0,C1,C2,nu,m)
II = dcmplx(0.d0,1.d0)
do i=1,ex(1)
do j=1,ex(2)
do k=1,ex(3)
!fake global coordinate is enough here
gr = 1.d0
tgrho = dtan(crho(i))
tgsigma = dtan(sigma(j))
tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0)
ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0)
select case (sst)
case (0)
z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = z*tgrho
y = z*tgsigma
case (1)
z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = z*tgrho
y = z*tgsigma
case (2)
x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
y = x*tgrho
z = x*tgsigma
case (3)
x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
y = x*tgrho
z = x*tgsigma
case (4)
y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = y*tgrho
z = y*tgsigma
case (5)
y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = y*tgrho
z = y*tgsigma
case default
write(*,*) "get_exact_omega: not recognized sst = ",sst
return
end select
gt = dacos(z/gr)
gp = datan2(y,x)
swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j))
if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf)
select case (sst)
case (0,1)
swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2)
case (2,3)
swtf = II*swtf*dsin(gt)
case (4,5)
swtf = -II*swtf*dsin(gt)
end select
gr = (1.d0-R(k))/R(k)/Rmin
Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*gr-C2/1.2d1*gr**3
gr = dreal(Jr*cdexp(II*nu*T))
Jr = Yslm(0,2,m,gt,gp)
omega(i,j,k) = 1.d0-2.d0*(2+1)/2.d0*gr*dreal(Jr)
enddo
enddo
enddo
return
end subroutine get_exact_omega
!-------------------------------------------------------------
! Linear wave given in Eq.(16) of CQG 24S327
!-------------------------------------------------------------
subroutine get_exact_news(ex,crho,sigma,R,RNews,INews,sst,Rmin,Time)
implicit none
! argument variables
integer, intent(in ):: ex(1:3),sst
real*8,intent(in) :: Rmin,Time
double precision,intent(in),dimension(ex(1))::crho
double precision,intent(in),dimension(ex(2))::sigma
double precision,intent(in),dimension(ex(3))::R
real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RNews,INews
integer :: i,j,k
real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts
double complex :: Yslm,II,Jr
double complex :: beta0,C1,C2
integer :: nu,m
double complex :: swtf,ff
call initial_null_paramter(beta0,C1,C2,nu,m)
II = dcmplx(0.d0,1.d0)
do i=1,ex(1)
do j=1,ex(2)
do k=1,ex(3)
!fake global coordinate is enough here
gr = 1.d0
tgrho = dtan(crho(i))
tgsigma = dtan(sigma(j))
tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0)
ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0)
select case (sst)
case (0)
z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = z*tgrho
y = z*tgsigma
case (1)
z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = z*tgrho
y = z*tgsigma
case (2)
x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
y = x*tgrho
z = x*tgsigma
case (3)
x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
y = x*tgrho
z = x*tgsigma
case (4)
y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = y*tgrho
z = y*tgsigma
case (5)
y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma)
x = y*tgrho
z = y*tgsigma
case default
write(*,*) "get_initial_null: not recognized sst = ",sst
return
end select
gt = dacos(z/gr)
gp = datan2(y,x)
swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j))
if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf)
select case (sst)
case (0,1)
swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2)
case (2,3)
swtf = II*swtf*dsin(gt)
case (4,5)
swtf = -II*swtf*dsin(gt)
end select
Jr = II*nu**3*C2/dsqrt(2.4d1)
gr = dreal(Jr)
Jr = Yslm(2,2,m,gt,gp)
ff = gr*Jr*swtf**2
RNews(i,j,k) = dreal(ff)
INews(i,j,k) = dimag(ff)
enddo
enddo
enddo
return
end subroutine get_exact_news