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

[TEST]UPSTREAM: Pick some source changes from 48080d0a97

Browse Source 
* Sync new folder structure
This commit is contained in:
ianchb
2026-04-23 20:55:40 +08:00
parent c185f99ee3
commit 17109fde9b
211 changed files with 189504 additions and 189280 deletions
Download Patch File Download Diff File Expand all files Collapse all files

690
AMSS_NCKU_source/Initial_Data_Solver/Ansorg.C Normal file
View File

@@ -0,0 +1,690 @@
#ifdef newc
#include <iostream>
#include <iomanip>
#include <fstream>
#include <strstream>
#include <cmath>
#include <cstdio>
using namespace std;
#else
#include <iostream.h>
#include <iomanip.h>
#include <fstream.h>
#include <string.h>
#include <math.h>
#include <stdio.h>
#endif
#include "Ansorg.h"
#include <cstring>
/* read spectral data from file
special: pad phi direction with ghosts for periodic interpolation
order = 4: (-2 -1) 0 ... n-1 (n n+1)
*/
Ansorg::Ansorg(char *filename, int orderi) : pu_ps(0), coordA(0), coordB(0), coordphi(0)
{
MPI_Comm_rank(MPI_COMM_WORLD, &myrank);
order = orderi / 2 * 2; // order must be even
PIh = PI / 2.0;
char s[1000], *t;
FILE *fp;
double *v;
int nghosts;
int i;
double x1, y1, z1, x2, y2, z2, dx, dy;
/* open file */
fp = fopen(filename, "r");
if (myrank == 0 && !fp)
{
cout << "could not open " << filename << " for reading Ansorg" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
if (myrank == 0)
printf(" reading data from %s\n", filename);
/* skip to line starting with data, extract size info */
n1 = n2 = n3 = ntotal = -1;
while (fgets(s, 1000, fp))
{
t = strstr(s, "bhx1 ");
if (t == s)
sscanf(s + 15, "%lf", &x1);
t = strstr(s, "bhy1 ");
if (t == s)
sscanf(s + 15, "%lf", &y1);
t = strstr(s, "bhz1 ");
if (t == s)
sscanf(s + 15, "%lf", &z1);
t = strstr(s, "bhx2 ");
if (t == s)
sscanf(s + 15, "%lf", &x2);
t = strstr(s, "bhy2 ");
if (t == s)
sscanf(s + 15, "%lf", &y2);
t = strstr(s, "bhz2 ");
if (t == s)
sscanf(s + 15, "%lf", &z2);
t = strstr(s, "data ");
if (t != s)
continue;
sscanf(s + 5, "%d%d%d", &n1, &n2, &n3);
ntotal = n1 * n2 * n3;
if (myrank == 0)
printf(" found data with dimensions %d x %d x %d = %d\n",
n1, n2, n3, ntotal);
break;
}
if (myrank == 0)
cout << " bhx1 = " << x1 << endl
<< " bhy1 = " << y1 << endl
<< " bhz1 = " << z1 << endl
<< " bhx2 = " << x2 << endl
<< " bhy2 = " << y2 << endl
<< " bhz2 = " << z2 << endl;
dx = x1 - x2;
dy = y1 - y2;
/* x-axis */
if (dx != 0 && y1 == 0 && y2 == 0 && z1 == 0 && z2 == 0)
{
ps_b = dx / 2;
ps_dx = (x1 + x2) / 2;
ps_rxx = 1;
ps_rxy = 0;
ps_ryx = 0;
ps_ryy = 1;
}
/* y-axis */
else if (dy != 0 && x1 == 0 && x2 == 0 && z1 == 0 && z2 == 0)
{
ps_b = dy / 2;
ps_dx = (y1 + y2) / 2;
ps_rxx = 0;
ps_rxy = +1;
ps_ryx = -1;
ps_ryy = 0;
}
/* else */
else if (myrank == 0)
{
cout << "puncture location not allowed" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
if (ntotal == -1 && myrank == 0)
{
cout << "file does not contain the expected data" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
/* get storage if needed */
int pad = order / 2;
nghosts = n1 * n2 * pad;
if (!(pu_ps))
pu_ps = new double[ntotal + 2 * nghosts];
v = pu_ps + nghosts;
/* read data */
i = 0;
while (fgets(s, 1000, fp))
{
if (i < ntotal)
v[i] = atof(t);
i++;
}
if (myrank == 0)
{
printf(" read %d data lines\n", i);
cout << endl;
}
if (myrank == 0 && i < ntotal)
{
cout << "file contains too few data lines" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
if (myrank == 0 && i > ntotal)
{
cout << "file contains too many data lines" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
/* copy data into ghosts */
for (i = 0; i < nghosts; i++)
{
(pu_ps)[i] = v[i + ntotal - nghosts];
(pu_ps)[i + ntotal + nghosts] = v[i];
}
if (0)
for (i = 0; i < ntotal + 2 * nghosts; i++)
printf("yoyo %10d %.16e\n", i - nghosts, (pu_ps)[i]);
/* done */
fclose(fp);
set_ABp();
if (0)
{
if (myrank == 0)
{
cout << ps_u_at_xyz(0.015625, -4.578125, 0.015625) << endl;
cout << ps_u_at_xyz(0.046875, -4.578125, 0.015625) << endl;
cout << ps_u_at_xyz(0.078125, -4.578125, 0.015625) << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
else
for (int i = 0;; i++)
;
}
}
Ansorg::~Ansorg()
{
if (coordA)
delete[] coordA;
if (coordB)
delete[] coordB;
if (coordphi)
delete[] coordphi;
if (pu_ps)
delete[] pu_ps;
}
/* interpolate to point given in Cartesian coordinates
calls function in utility/interpolation/barycentric.c
*/
double Ansorg::ps_u_at_xyz(double x, double y, double z)
{
double A, B, phi, u, U;
/*
// rotate THETA along clockwise direction
#define THETA (PI*0.25)
A = x;
B = y;
x = A*cos(THETA)+B*sin(THETA);
y =-A*sin(THETA)+B*cos(THETA);
*/
xyz_to_ABp(x, y, z, &A, &B, &phi);
if (0)
printf("x %f y %f z %f phi %f %.1f\n", x, y, z, phi, 180 * phi / PI);
if (0)
printf("A %f B %f phi %f\n", A, B, phi);
U = interpolate_tri_bar(A, B, phi, n1, n2, n3 + (order / 2) * 2,
coordA, coordB, coordphi, pu_ps);
u = 2 * (A - 1) * U;
if (U > 0.025)
cout << x << "," << y << "," << z << "," << A << "," << B << "," << phi << "," << U << "," << u << endl;
if (!finite(u))
{
cout << "find NaN in Ansorg::ps_u_at_xyz at (" << x << "," << y << "," << z << ")" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
return u;
}
/* set 1d arrays for spectral coordinates
see Punctures_functions.c for reference
special: pad phi direction with ghosts for periodicity
*/
void Ansorg::set_ABp()
{
int pad = order / 2;
int i;
double Acode;
int pr = 0;
coordA = new double[n1];
coordB = new double[n2];
coordphi = new double[n3 + 2 * pad];
for (i = 0; i < n1; i++)
{
Acode = -cos(PIh * (2 * i + 1) / n1);
coordA[i] = (Acode + 1) / 2;
if (pr && myrank == 0)
printf("coordA[%2d] = %f\n", i, coordA[i]);
}
for (i = 0; i < n2; i++)
{
coordB[i] = -cos(PIh * (2 * i + 1) / n2);
if (pr && myrank == 0)
printf("coordB[%2d] = %f\n", i, coordB[i]);
}
for (i = 0; i < n3 + 2 * pad; i++)
{
coordphi[i] = 2 * PI * (i - pad) / n3;
if (pr && myrank == 0)
printf("coordphi[%2d] = %f %f\n",
i, coordphi[i], coordphi[i] * 180 / PI);
}
}
/* from cartesian to spectral
see coordtrans.m etc
The problem is that the inverse transformation requires several
nested square roots with 8 possible solutions, only one of them relevant.
We have picked the correct solution by testing in Mathematica.
Furthermore, there are special coordinates where the formulas have
to be specialized.
fixme: needs proper treatment of quantities that are almost zero/singular
*/
#if 0
void Ansorg::xyz_to_ABp(double x, double y, double z,
double *A, double *B, double *phi)
{
const double s2 = sqrt(2.0);
double r, rr, xx;
double t, st, u, su, v, sv, w, sw;
/* rotate onto x-axis if required */
w = x;
x = ps_rxx * w + ps_rxy * y;
y = ps_ryx * w + ps_ryy * y;
/* center black holes at +b and -b */
x -= ps_dx;
/* offset parameter b rescales the coordinates */
x /= ps_b;
y /= ps_b;
z /= ps_b;
/* helpers */
r = sqrt(y*y + z*z);
rr = r*r;
xx = x*x;
/* phi as in cylindrical coordinates about x-axis
acos covers [0,pi], we need [0,2pi)
*/
if (r>0.0)
*phi = (z < 0.0) ? 2*PI - acos(y/r) : acos(y/r);
else
*phi = 0;
/* r > 0 */
if (r>0.0) {
/* x != 0, r > 0 */
if (x != 0.0) {
t = (1+rr)*(1+rr) + 2*(-1 + rr)*xx + xx*xx;
st = sqrt(t);
u = 1 - xx + rr*(2 + rr + xx + st) + st;
su = sqrt(u);
v = 1 + rr*rr - xx + rr*(2 + xx + st) + st;
sv = sqrt(v);
w = 1 + rr - s2*su + st;
sw = sqrt(w);
*A = (2*sw*(1 + rr + st - xx) + s2*sv*(-1 - rr + 2*sw + st - xx))
/(4.*r*xx);
*B = -(sw/x);
}
/* x == 0, r > 0 */
else {
*A = (sqrt(1+rr) - 1)/r;
*B = 0;
}
}
/* r == 0 */
else {
/* x > 1, r == 0 */
if (x>1.0) {
*A = sqrt(x-1)/sqrt(x+1);
*B = -1;
}
/* x < -1, r == 0 */
else if (x<-1.0) {
*A = sqrt(-x-1)/sqrt(-x+1);
*B = +1;
}
/* -1 <= x <= 1, r == 0 */
else {
*A = 0;
/* x != 0 */
if (x != 0.0)
*B = (sqrt(1-xx) - 1)/x;
/* x == 0 */
else
*B = 0;
}
}
if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1) {*A = 1; *B = 0;}
if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1 || (*phi)<0 || (*phi)>2*PI){
cout<<"find ("<<*A<<","<<*B<<","<<*phi<<") in Ansorg::xyz_to_ABp at ("<<x<<","<<y<<","<<z
<<") t u v w "<<t<<","<<u<<","<<v<<","<<w<<endl;
cout<<2*sw*(rr + st + 1 - xx)<<","<< s2*sv*(st - rr - 1 + 2*sw - xx)<<"LAST"<<endl;
MPI_Abort(MPI_COMM_WORLD,1);
}
}
#endif
#if 0
void Ansorg::xyz_to_ABp(double x, double y, double z,
double *A, double *B, double *phi)
{
const double s2 = sqrt(2.0);
const double exp = 3.0/2.0;
double r, rr, xx;
double t, st, u, su, v, sv, w, sw;
/* rotate onto x-axis if required */
w = x;
x = ps_rxx * w + ps_rxy * y;
y = ps_ryx * w + ps_ryy * y;
/* center black holes at +b and -b */
x -= ps_dx;
/* offset parameter b rescales the coordinates */
x /= ps_b;
y /= ps_b;
z /= ps_b;
/* helpers */
r = sqrt(y*y + z*z);
rr = r*r;
xx = x*x;
/* phi as in cylindrical coordinates about x-axis
acos covers [0,pi], we need [0,2pi)
*/
if (r>0)
*phi = (z<0) ? 2*PI - acos(y/r) : acos(y/r);
else
*phi = 0;
/* r > 0 */
{
/* x != 0, r > 0 */
{
t = (1+rr)*(1+rr) + 2*(-1 + rr)*xx + xx*xx;
st = sqrt(t);
u = rr*(2 + rr + xx + st) + st + 1.0 - xx;
su = sqrt(u);
v = rr*rr + rr*(2 + xx + st) + st + 1.0 - xx;
sv = sqrt(v);
w = rr - s2*su + st + 1.0;
sw = sqrt(w);
*A = (2*sw*(rr + st + 1 - xx) + s2*sv*(st - rr - 1 + 2*sw - xx))
/(4.*r*xx);
*B = -(sw/x);
}
/* x == 0, r > 0 */
if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1)
{
*A = (sqrt(1 + rr) - 1)/r + ((sqrt(1 + rr) - 1)*xx)/(2*r*pow((1 + rr),exp));
*B = -x/(2*sqrt(1 + rr));
}
}
/* r == 0 */
if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1)
{
/* x > 1, r == 0 */
if (x>1) {
*A = sqrt(x-1)/sqrt(x+1);
*B = -1;
}
/* x < -1, r == 0 */
else if (x<-1) {
*A = sqrt(-x-1)/sqrt(-x+1);
*B = +1;
}
/* -1 <= x <= 1, r == 0 */
else {
*A = 0;
/* x != 0 */
if (x != 0)
*B = (sqrt(1-xx) - 1)/x;
/* x == 0 */
else
*B = 0;
}
}
double aux1 = 0.5 * (x * x + rr - 1);
double aux2 = sqrt (aux1 * aux1 + rr);
double X = asinh (sqrt (aux1 + aux2));
double R = asin (min(1.0, sqrt (-aux1 + aux2)));
if (x < 0) R = PI - R;
*A = tanh (0.5 * X);
*B = tan (0.5 * R - PI/4);
if((*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1 || (*phi)<0 || (*phi)>2*PI){
cout<<"find ("<<*A<<","<<*B<<","<<*phi<<") in Ansorg::xyz_to_ABp at ("<<x<<","<<y<<","<<z
<<") t u v w "<<t<<","<<u<<","<<v<<","<<w<<endl;
cout<<2*sw*(rr + st + 1 - xx)<<","<< s2*sv*(st - rr - 1 + 2*sw - xx)<<"LAST"<<endl;
MPI_Abort(MPI_COMM_WORLD,1);
}
}
#endif
#if 1
// adopting the coordinate transformation in TwoPunctures Thorn on Jan 23, 2011
void Ansorg::xyz_to_ABp(double x, double y, double z,
double *A, double *B, double *phi)
{
const double s2 = sqrt(2.0);
const double exp = 3.0 / 2.0;
double r, rr, xx;
double t, st, u, su, v, sv, w, sw;
/* rotate onto x-axis if required */
w = x;
x = ps_rxx * w + ps_rxy * y;
y = ps_ryx * w + ps_ryy * y;
/* center black holes at +b and -b */
x -= ps_dx;
/* offset parameter b rescales the coordinates */
x /= ps_b;
y /= ps_b;
z /= ps_b;
/* helpers */
r = sqrt(y * y + z * z);
rr = r * r;
xx = x * x;
/* this work worse than the next one
*phi = atan2(z, y);
if (*phi < 0) *phi += 2 * PI;
*/
if (r > 0)
*phi = (z < 0) ? 2 * PI - acos(y / r) : acos(y / r);
else
*phi = 0;
double aux1 = 0.5 * (x * x + rr - 1);
double aux2 = sqrt(aux1 * aux1 + rr);
double X = asinh(sqrt(aux1 + aux2));
double R = asin(min(1.0, sqrt(-aux1 + aux2)));
if (x < 0)
R = PI - R;
*A = tanh(0.5 * X);
*B = tan(0.5 * R - PI / 4);
}
#endif
/* three dimensional polynomial interpolation, barycentric */
double Ansorg::interpolate_tri_bar(double x, double y, double z,
int n1, int n2, int n3,
double *x1, double *x2, double *x3, double *yp)
{
double u;
double *w, *omega;
double **v;
int i, j, k, ijk;
int i1, i2, i3;
int di = 1, dj = n1, dk = n1 * n2;
int order1 = order > n1 ? n1 : order;
int order2 = order > n2 ? n2 : order;
int order3 = order > n3 ? n3 : order;
w = new double[order];
omega = new double[order];
v = new double *[order];
for (int i = 0; i < order; i++)
v[i] = new double[order];
i1 = find_point_bisection(x, n1, x1, order1 / 2);
i2 = find_point_bisection(y, n2, x2, order2 / 2);
i3 = find_point_bisection(z, n3, x3, order3 / 2);
ijk = i1 * di + i2 * dj + i3 * dk;
if (0)
printf("%d %d %d\n", i1, i2, i3);
barycentric_omega(order1, 1, &x1[i1], omega);
for (k = 0; k < order3; k++)
for (j = 0; j < order2; j++)
v[k][j] = barycentric(x, order1, 1, &x1[i1], &yp[ijk + j * dj + k * dk], omega);
if (0)
for (k = 0; k < order3; k++)
for (j = 0; j < order2; j++)
printf("%2d %2d %.15f\n", k, j, v[k][j]);
barycentric_omega(order2, 1, &x2[i2], omega);
for (k = 0; k < order3; k++)
w[k] = barycentric(y, order2, 1, &x2[i2], &v[k][0], omega);
if (0)
for (k = 0; k < order3; k++)
printf("%2d %.15f\n", k, w[k]);
barycentric_omega(order3, 1, &x3[i3], omega);
u = barycentric(z, order3, 1, &x3[i3], w, omega);
if (!finite(u))
{
cout << "find NaN in Ansorg::interpolate_tri_bar at (" << x << "," << y << "," << z << ")" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
for (i = 0; i < order; i++)
delete[] v[i];
delete[] w;
delete[] omega;
delete[] v;
return u;
}
/* find index such that xp[i] <= x < xp[i+1]
uses bisection, which relies on x being ordered
o is "offset", number of points smaller than x that are required
returns j = i-(o-1), i.e. if o = 2, then
xp[j] < xp[j+1] <= x < xp[j+2] < xp[j+3]
which is useful for interpolation
*/
int Ansorg::find_point_bisection(double x, int n, double *xp, int o)
{
int i0 = o - 1, i1 = n - o;
int i;
if (n < 2 * o)
{
cout << "bisection failed" << endl;
MPI_Abort(MPI_COMM_WORLD, 1);
}
if (x <= xp[i0])
return 0;
if (x > xp[i1])
return n - 2 * o;
while (i0 != i1 - 1)
{
i = (i0 + i1) / 2;
if (x < xp[i])
i1 = i;
else
i0 = i;
}
return i0 - o + 1;
}
/* compute omega[] for barycentric interpolation */
// SIAM_review 46, 501 (2004)
void Ansorg::barycentric_omega(int n, int s, double *x, double *omega)
{
double o;
int i, j;
if (0)
printf("%d %d %p %p\n", n, s, x, omega);
for (i = 0; i < n; i += s)
{
o = 1;
for (j = 0; j < n; j += s)
{
if (j != i)
{
o /= (x[i] - x[j]);
}
}
omega[i / s] = o;
if (0)
printf("x[%d] = %9.6f omega[%d] = %13.6e\n", i / s, x[i], i / s, o);
}
}
/* barycentric interpolation with precomputed omega */
double Ansorg::barycentric(double x0, int n, int s, double *x, double *y,
double *omega)
{
double a, b, c, d;
int i;
if (0)
printf("%f %d %d %p %p %p\n", x0, n, s, x, y, omega);
a = b = 0;
for (i = 0; i < n; i += s)
{
d = x0 - x[i];
if (d == 0)
return y[i];
c = omega[i / s] / d;
b += c;
a += c * y[i];
}
return a / b;
}

53
AMSS_NCKU_source/Initial_Data_Solver/Ansorg.h Normal file
View File

@@ -0,0 +1,53 @@
#ifndef Ansorg_H
#define Ansorg_H
#ifdef newc
#include <iostream>
#include <iomanip>
#include <fstream>
#include <cstdlib>
#include <string>
#include <cmath>
using namespace std;
#else
#include <iostream.h>
#include <iomanip.h>
#include <fstream.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#endif
#include <mpi.h>
#define PI M_PI
class Ansorg
{
protected:
int n1, n2, n3, ntotal;
int order;
double *coordA, *coordB, *coordphi;
int ps_rxx, ps_rxy, ps_ryx, ps_ryy;
double ps_b, ps_dx;
double PIh;
double *pu_ps;
int myrank;
public:
Ansorg(char *filename, int orderi);
~Ansorg();
double ps_u_at_xyz(double x, double y, double z);
void set_ABp();
void xyz_to_ABp(double x, double y, double z,
double *A, double *B, double *phi);
double interpolate_tri_bar(double x, double y, double z,
int n1, int n2, int n3,
double *x1, double *x2, double *x3, double *yp);
int find_point_bisection(double x, int n, double *xp, int o);
void barycentric_omega(int n, int s, double *x, double *omega);
double barycentric(double x0, int n, int s, double *x, double *y,
double *omega);
};
#endif /* Ansorg_H */

977
AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.f90 Normal file
View File

@@ -0,0 +1,977 @@
!-----------------------------------------------------------------------------------
!
!Set up approximate puncture initial data for n charged black holes
!PRD 80, 104022
!-----------------------------------------------------------------------------------
subroutine get_initial_nbhsem(ext,X,Y,Z, &
chi, trK, &
gxx, gxy, gxz, gyy, gyz, gzz,&
Axx, Axy, Axz, Ayy, Ayz, Azz,&
Gmx, Gmy, Gmz, &
Lap, Sfx, Sfy, Sfz,&
dtSfx,dtSfy,dtSfz,&
Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,&
Mass,Qchar,Porg,Pmom,Spin,N)
implicit none
!------= input arguments
integer,intent(in) :: N
integer, dimension(3), intent(in) :: ext
real*8, dimension(ext(1)), intent(in) :: X
real*8, dimension(ext(2)), intent(in) :: Y
real*8, dimension(ext(3)), intent(in) :: Z
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: chi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz
real*8, dimension(N), intent(in) :: Mass,Qchar
real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin
!------= local variables
real*8,dimension(ext(1),ext(2),ext(3))::psi,phi
integer :: i,j,k,bhi
real*8 :: M,Q,Px,Py,Pz,PP,Sx,Sy,Sz,SS
real*8 :: nx,ny,nz,rr,tmp
real*8 :: u,u1,u2,u3,u4
real*8 :: mup,mus,b,ell
real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0
real*8,parameter::TINYRR=1.d-14
!sanity check: M/Q = constant
M = mass(1)
Q = Qchar(1)
u1 = M/Q
u2 = M/Q
do bhi=2,N
M = mass(bhi)
Q = Qchar(bhi)
u1 = min(u1,M/Q)
u2 = max(u2,M/Q)
enddo
if(u2-u1.gt.TINYRR)then
write(*,*)"error in initial_punctureem.f90: get_initial_nbhsem; we need constant Mi/Qi, but"
write(*,*)"Mass = ",mass
write(*,*)"Qchar = ",Qchar
stop
endif
do k = 1,ext(3)
do j = 1,ext(2)
do i = 1,ext(1)
! black hole 1
M = mass(1)
Q = Qchar(1)
nx = x(i) - Porg(1)
ny = y(j) - Porg(2)
nz = z(k) - Porg(3)
Px = Pmom(1)
Py = Pmom(2)
Pz = Pmom(3)
Sx = Spin(1)
Sy = Spin(2)
Sz = Spin(3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0
nx = nx / rr
ny = ny / rr
nz = nz / rr
PP = dsqrt(Px**2 + Py**2 + Pz**2)
if(PP .gt. 0.d0) then
mup = (Px*nx+Py*ny+Pz*nz)/PP
else
mup = 0.0
endif
SS = dsqrt(Sx**2 + Sy**2 + Sz**2)
if(SS .gt. 0.d0) then
mus = (Sx*nx+Sy*ny+Sz*nz)/SS
else
mus = 0.0
endif
b = 2.d0*rr/M
ell = 1.d0/(1.d0+b)
u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0)
u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 &
+8.4d1*dlog(ell)/b)/4.d1/b**2
u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4)
u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3)
tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz
u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + &
6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp
psi(i,j,k) = ONE + u + HLF*M/rr
phi(i,j,k) = Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Q*nx/rr/rr
Ey(i,j,k) = Q*ny/rr/rr
Ez(i,j,k) = Q*nz/rr/rr
! black hole 2 and 3, ...
do bhi=2,N
M = Mass(bhi)
Q = Qchar(bhi)
nx = x(i) - Porg(3*(bhi-1)+1)
ny = y(j) - Porg(3*(bhi-1)+2)
nz = z(k) - Porg(3*(bhi-1)+3)
Px = Pmom(3*(bhi-1)+1)
Py = Pmom(3*(bhi-1)+2)
Pz = Pmom(3*(bhi-1)+3)
Sx = Spin(3*(bhi-1)+1)
Sy = Spin(3*(bhi-1)+2)
Sz = Spin(3*(bhi-1)+3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0
nx = nx / rr
ny = ny / rr
nz = nz / rr
PP = dsqrt(Px**2 + Py**2 + Pz**2)
if(PP .gt. 0.d0) then
mup = (Px*nx+Py*ny+Pz*nz)/PP
else
mup = 0.0
endif
SS = dsqrt(Sx**2 + Sy**2 + Sz**2)
if(SS .gt. 0.d0) then
mus = (Sx*nx+Sy*ny+Sz*nz)/SS
else
mus = 0.0
endif
b = 2.d0*rr/M
ell = 1.d0/(1.d0+b)
u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0)
u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 &
+8.4d1*dlog(ell)/b)/4.d1/b**2
u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4)
u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3)
tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz
u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + &
6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp
psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr
phi(i,j,k) = phi(i,j,k) + Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = Axx(i,j,k) + &
(HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = Ayy(i,j,k) + &
(HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = Azz(i,j,k) + &
(HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = Axy(i,j,k) + &
(HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = Axz(i,j,k) + &
(HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = Ayz(i,j,k) + &
(HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr
Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr
Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr
enddo
enddo
enddo
enddo
psi = dsqrt(psi**2 - phi*phi/FOUR)
chi = ONE / psi **4 - ONE
Lap = ONE / ( psi * psi ) - ONE
!~~~~~~ tilde Aij = Aij / Psi^6
psi = psi * psi * psi * psi * psi * psi
Axx = Axx / psi
Ayy = Ayy / psi
Azz = Azz / psi
Axy = Axy / psi
Axz = Axz / psi
Ayz = Ayz / psi
Ex = Ex / psi
Ey = Ey / psi
Ez = Ez / psi
gxx = ZEO
gyy = ZEO
gzz = ZEO
gxy = ZEO
gxz = ZEO
gyz = ZEO
trK = ZEO
Gmx = ZEO
Gmy = ZEO
Gmz = ZEO
Sfx = ZEO
Sfy = ZEO
Sfz = ZEO
dtSfx = ZEO
dtSfy = ZEO
dtSfz = ZEO
Bx = ZEO
By = ZEO
Bz = ZEO
Kpsi = ZEO
Kphi = ZEO
return
end subroutine get_initial_nbhsem
!-----------------------------------------------------------------------------------
!
!Set up approximate puncture initial data for n charged black holes
!PRD 80, 104022
! for shell
!-----------------------------------------------------------------------------------
subroutine get_initial_nbhsem_ss(ext,X,Y,Z, &
chi, trK, &
gxx, gxy, gxz, gyy, gyz, gzz,&
Axx, Axy, Axz, Ayy, Ayz, Azz,&
Gmx, Gmy, Gmz, &
Lap, Sfx, Sfy, Sfz,&
dtSfx,dtSfy,dtSfz,&
Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,&
Mass,Qchar,Porg,Pmom,Spin,N)
implicit none
!------= input arguments
integer,intent(in) :: N
integer, dimension(3), intent(in) :: ext
real*8, dimension(ext(1),ext(2),ext(3)), intent(in) :: X,Y,Z
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: chi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz
real*8, dimension(N), intent(in) :: Mass,Qchar
real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin
!------= local variables
real*8,dimension(ext(1),ext(2),ext(3))::psi,phi
integer :: i,j,k,bhi
real*8 :: M,Q,Px,Py,Pz,PP,Sx,Sy,Sz,SS
real*8 :: nx,ny,nz,rr,tmp
real*8 :: u,u1,u2,u3,u4
real*8 :: mup,mus,b,ell
real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0
real*8,parameter::TINYRR=1.d-14
!sanity check: M/Q = constant
M = mass(1)
Q = Qchar(1)
u1 = M/Q
u2 = M/Q
do bhi=2,N
M = mass(bhi)
Q = Qchar(bhi)
u1 = min(u1,M/Q)
u2 = max(u2,M/Q)
enddo
if(u2-u1.gt.TINYRR)then
write(*,*)"error in initial_punctureem.f90: get_initial_nbhsem; we need constant Mi/Qi, but"
write(*,*)"Mass = ",mass
write(*,*)"Qchar = ",Qchar
stop
endif
do k = 1,ext(3)
do j = 1,ext(2)
do i = 1,ext(1)
! black hole 1
M = mass(1)
Q = Qchar(1)
nx = x(i,j,k) - Porg(1)
ny = y(i,j,k) - Porg(2)
nz = z(i,j,k) - Porg(3)
Px = Pmom(1)
Py = Pmom(2)
Pz = Pmom(3)
Sx = Spin(1)
Sy = Spin(2)
Sz = Spin(3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=TINYRR
nx = nx / rr
ny = ny / rr
nz = nz / rr
PP = dsqrt(Px**2 + Py**2 + Pz**2)
if(PP .gt. 0.d0) then
mup = (Px*nx+Py*ny+Pz*nz)/PP
else
mup = 0.0
endif
SS = dsqrt(Sx**2 + Sy**2 + Sz**2)
if(SS .gt. 0.d0) then
mus = (Sx*nx+Sy*ny+Sz*nz)/SS
else
mus = 0.0
endif
b = 2.d0*rr/M
ell = 1.d0/(1.d0+b)
u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0)
u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 &
+8.4d1*dlog(ell)/b)/4.d1/b**2
u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4)
u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3)
tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz
u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + &
6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp
psi(i,j,k) = ONE + u + HLF*M/rr
phi(i,j,k) = Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Q*nx/rr/rr
Ey(i,j,k) = Q*ny/rr/rr
Ez(i,j,k) = Q*nz/rr/rr
! black hole 2 and 3, ...
do bhi=2,N
M = Mass(bhi)
Q = Qchar(bhi)
nx = x(i,j,k) - Porg(3*(bhi-1)+1)
ny = y(i,j,k) - Porg(3*(bhi-1)+2)
nz = z(i,j,k) - Porg(3*(bhi-1)+3)
Px = Pmom(3*(bhi-1)+1)
Py = Pmom(3*(bhi-1)+2)
Pz = Pmom(3*(bhi-1)+3)
Sx = Spin(3*(bhi-1)+1)
Sy = Spin(3*(bhi-1)+2)
Sz = Spin(3*(bhi-1)+3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=TINYRR
nx = nx / rr
ny = ny / rr
nz = nz / rr
PP = dsqrt(Px**2 + Py**2 + Pz**2)
if(PP .gt. 0.d0) then
mup = (Px*nx+Py*ny+Pz*nz)/PP
else
mup = 0.0
endif
SS = dsqrt(Sx**2 + Sy**2 + Sz**2)
if(SS .gt. 0.d0) then
mus = (Sx*nx+Sy*ny+Sz*nz)/SS
else
mus = 0.0
endif
b = 2.d0*rr/M
ell = 1.d0/(1.d0+b)
u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0)
u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 &
+8.4d1*dlog(ell)/b)/4.d1/b**2
u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4)
u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3)
tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz
u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + &
6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp
psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr
phi(i,j,k) = phi(i,j,k) + Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = Axx(i,j,k) + &
(HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = Ayy(i,j,k) + &
(HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = Azz(i,j,k) + &
(HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = Axy(i,j,k) + &
(HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = Axz(i,j,k) + &
(HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = Ayz(i,j,k) + &
(HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr
Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr
Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr
enddo
enddo
enddo
enddo
psi = dsqrt(psi**2 - phi*phi/FOUR)
chi = ONE / psi **4 - ONE
Lap = ONE / ( psi * psi ) - ONE
!~~~~~~ tilde Aij = Aij / Psi^6
psi = psi * psi * psi * psi * psi * psi
Axx = Axx / psi
Ayy = Ayy / psi
Azz = Azz / psi
Axy = Axy / psi
Axz = Axz / psi
Ayz = Ayz / psi
Ex = Ex / psi
Ey = Ey / psi
Ez = Ez / psi
gxx = ZEO
gyy = ZEO
gzz = ZEO
gxy = ZEO
gxz = ZEO
gyz = ZEO
trK = ZEO
Gmx = ZEO
Gmy = ZEO
Gmz = ZEO
Sfx = ZEO
Sfy = ZEO
Sfz = ZEO
dtSfx = ZEO
dtSfy = ZEO
dtSfz = ZEO
Bx = ZEO
By = ZEO
Bz = ZEO
Kpsi = ZEO
Kphi = ZEO
return
end subroutine get_initial_nbhsem_ss
!-----------------------------------------------------------------------------------
!
!Set up approximate puncture initial data for n charged black holes
!aided with Ansorg's solver
!-----------------------------------------------------------------------------------
subroutine get_ansorg_nbhs_em(ext,X,Y,Z, &
chi, trK, &
gxx, gxy, gxz, gyy, gyz, gzz,&
Axx, Axy, Axz, Ayy, Ayz, Azz,&
Gmx, Gmy, Gmz, &
Lap, Sfx, Sfy, Sfz,&
dtSfx,dtSfy,dtSfz,&
Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,&
Mass,Qchar,Porg,Pmom,Spin,N)
implicit none
!------= input arguments
integer,intent(in) :: N
integer, dimension(3), intent(in) :: ext
real*8, dimension(ext(1)), intent(in) :: X
real*8, dimension(ext(2)), intent(in) :: Y
real*8, dimension(ext(3)), intent(in) :: Z
real*8, dimension(ext(1),ext(2),ext(3)), intent(inout) :: chi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz
real*8, dimension(N), intent(in) :: Mass,Qchar
real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin
!------= local variables
real*8,dimension(ext(1),ext(2),ext(3))::psi,phi
integer :: i,j,k,bhi
real*8 :: M,Q,Px,Py,Pz,Sx,Sy,Sz
real*8 :: nx,ny,nz,rr,tmp
real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0
real*8,parameter::TINYRR=1.d-14
do k = 1,ext(3)
do j = 1,ext(2)
do i = 1,ext(1)
! black hole 1
M = mass(1)
Q = Qchar(1)
nx = x(i) - Porg(1)
ny = y(j) - Porg(2)
nz = z(k) - Porg(3)
Px = Pmom(1)
Py = Pmom(2)
Pz = Pmom(3)
Sx = Spin(1)
Sy = Spin(2)
Sz = Spin(3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0
nx = nx / rr
ny = ny / rr
nz = nz / rr
psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr
phi(i,j,k) = Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Q*nx/rr/rr
Ey(i,j,k) = Q*ny/rr/rr
Ez(i,j,k) = Q*nz/rr/rr
! black hole 2 and 3, ...
do bhi=2,N
M = Mass(bhi)
Q = Qchar(bhi)
nx = x(i) - Porg(3*(bhi-1)+1)
ny = y(j) - Porg(3*(bhi-1)+2)
nz = z(k) - Porg(3*(bhi-1)+3)
Px = Pmom(3*(bhi-1)+1)
Py = Pmom(3*(bhi-1)+2)
Pz = Pmom(3*(bhi-1)+3)
Sx = Spin(3*(bhi-1)+1)
Sy = Spin(3*(bhi-1)+2)
Sz = Spin(3*(bhi-1)+3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0
nx = nx / rr
ny = ny / rr
nz = nz / rr
psi(i,j,k) = psi(i,j,k) + HLF*M/rr
phi(i,j,k) = phi(i,j,k) + Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = Axx(i,j,k) + &
(HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = Ayy(i,j,k) + &
(HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = Azz(i,j,k) + &
(HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = Axy(i,j,k) + &
(HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = Axz(i,j,k) + &
(HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = Ayz(i,j,k) + &
(HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr
Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr
Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr
enddo
enddo
enddo
enddo
psi = dsqrt(psi**2 - phi*phi/FOUR)
chi = ONE / psi **4 - ONE
Lap = ONE / ( psi * psi ) - ONE
!~~~~~~ tilde Aij = Aij / Psi^6
psi = psi * psi * psi * psi * psi * psi
Axx = Axx / psi
Ayy = Ayy / psi
Azz = Azz / psi
Axy = Axy / psi
Axz = Axz / psi
Ayz = Ayz / psi
Ex = Ex / psi
Ey = Ey / psi
Ez = Ez / psi
gxx = ZEO
gyy = ZEO
gzz = ZEO
gxy = ZEO
gxz = ZEO
gyz = ZEO
trK = ZEO
Gmx = ZEO
Gmy = ZEO
Gmz = ZEO
Sfx = ZEO
Sfy = ZEO
Sfz = ZEO
dtSfx = ZEO
dtSfy = ZEO
dtSfz = ZEO
Bx = ZEO
By = ZEO
Bz = ZEO
Kpsi = ZEO
Kphi = ZEO
return
end subroutine get_ansorg_nbhs_em
!-----------------------------------------------------------------------------------
!
!Set up approximate puncture initial data for n charged black holes
!aided with Ansorg's solver
! for shell
!-----------------------------------------------------------------------------------
subroutine get_ansorg_nbhs_ss_em(ext,X,Y,Z, &
chi, trK, &
gxx, gxy, gxz, gyy, gyz, gzz,&
Axx, Axy, Axz, Ayy, Ayz, Azz,&
Gmx, Gmy, Gmz, &
Lap, Sfx, Sfy, Sfz,&
dtSfx,dtSfy,dtSfz,&
Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,&
Mass,Qchar,Porg,Pmom,Spin,N)
implicit none
!------= input arguments
integer,intent(in) :: N
integer, dimension(3), intent(in) :: ext
real*8, dimension(ext(1),ext(2),ext(3)), intent(in) :: X,Y,Z
real*8, dimension(ext(1),ext(2),ext(3)), intent(inout) :: chi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz
real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz
real*8, dimension(N), intent(in) :: Mass,Qchar
real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin
!------= local variables
real*8,dimension(ext(1),ext(2),ext(3))::psi,phi
integer :: i,j,k,bhi
real*8 :: M,Q,Px,Py,Pz,Sx,Sy,Sz
real*8 :: nx,ny,nz,rr,tmp
real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0
real*8,parameter::TINYRR=1.d-14
do k = 1,ext(3)
do j = 1,ext(2)
do i = 1,ext(1)
! black hole 1
M = mass(1)
Q = Qchar(1)
nx = x(i,j,k) - Porg(1)
ny = y(i,j,k) - Porg(2)
nz = z(i,j,k) - Porg(3)
Px = Pmom(1)
Py = Pmom(2)
Pz = Pmom(3)
Sx = Spin(1)
Sy = Spin(2)
Sz = Spin(3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=TINYRR
nx = nx / rr
ny = ny / rr
nz = nz / rr
psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr
phi(i,j,k) = Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Q*nx/rr/rr
Ey(i,j,k) = Q*ny/rr/rr
Ez(i,j,k) = Q*nz/rr/rr
! black hole 2 and 3, ...
do bhi=2,N
M = Mass(bhi)
Q = Qchar(bhi)
nx = x(i,j,k) - Porg(3*(bhi-1)+1)
ny = y(i,j,k) - Porg(3*(bhi-1)+2)
nz = z(i,j,k) - Porg(3*(bhi-1)+3)
Px = Pmom(3*(bhi-1)+1)
Py = Pmom(3*(bhi-1)+2)
Pz = Pmom(3*(bhi-1)+3)
Sx = Spin(3*(bhi-1)+1)
Sy = Spin(3*(bhi-1)+2)
Sz = Spin(3*(bhi-1)+3)
rr = dsqrt(nx*nx+ny*ny+nz*nz)
if(rr.lt.TINYRR) rr=TINYRR
nx = nx / rr
ny = ny / rr
nz = nz / rr
psi(i,j,k) = psi(i,j,k) + HLF*M/rr
phi(i,j,k) = phi(i,j,k) + Q/rr
tmp = Px * nx + Py * ny + Pz * nz
Axx(i,j,k) = Axx(i,j,k) + &
(HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + &
( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayy(i,j,k) = Ayy(i,j,k) + &
(HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + &
( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Azz(i,j,k) = Azz(i,j,k) + &
(HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + &
( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * &
THR / ( rr * rr )
Axy(i,j,k) = Axy(i,j,k) + &
(HLF *( Px * ny + nx * Py + nx * ny * tmp ) + &
( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Axz(i,j,k) = Axz(i,j,k) + &
(HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + &
( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * &
THR / ( rr * rr )
Ayz(i,j,k) = Ayz(i,j,k) + &
(HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + &
( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * &
THR / ( rr * rr )
Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr
Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr
Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr
enddo
enddo
enddo
enddo
psi = dsqrt(psi**2 - phi*phi/FOUR)
chi = ONE / psi **4 - ONE
Lap = ONE / ( psi * psi ) - ONE
!~~~~~~ tilde Aij = Aij / Psi^6
psi = psi * psi * psi * psi * psi * psi
Axx = Axx / psi
Ayy = Ayy / psi
Azz = Azz / psi
Axy = Axy / psi
Axz = Axz / psi
Ayz = Ayz / psi
Ex = Ex / psi
Ey = Ey / psi
Ez = Ez / psi
gxx = ZEO
gyy = ZEO
gzz = ZEO
gxy = ZEO
gxz = ZEO
gyz = ZEO
trK = ZEO
Gmx = ZEO
Gmy = ZEO
Gmz = ZEO
Sfx = ZEO
Sfy = ZEO
Sfz = ZEO
dtSfx = ZEO
dtSfy = ZEO
dtSfz = ZEO
Bx = ZEO
By = ZEO
Bz = ZEO
Kpsi = ZEO
Kphi = ZEO
return
end subroutine get_ansorg_nbhs_ss_em

76
AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.h Normal file
View File

@@ -0,0 +1,76 @@
#ifndef GET_INITIAL_MAXWELL_H
#define GET_INITIAL_MAXWELL_H
#ifdef fortran1
#define f_get_initial_nbhsem get_initial_nbhsem
#define f_get_initial_nbhsem_ss get_initial_nbhsem_ss
#define f_get_ansorg_nbhs_em get_ansorg_nbhs_em
#define f_get_ansorg_nbhs_ss_em get_ansorg_nbhs_ss_em
#endif
#ifdef fortran2
#define f_get_initial_nbhsem GET_INITIAL_NBHSEM
#define f_get_initial_nbhsem_ss GET_INITIAL_NBHSEM_SS
#define f_get_ansorg_nbhs_em GET_ANSORG_NBHS_EM
#define f_get_ansorg_nbhs_ss_em GET_ANSORG_NBHS_SS_EM
#endif
#ifdef fortran3
#define f_get_initial_nbhsem get_initial_nbhsem_
#define f_get_initial_nbhsem_ss get_initial_nbhsem_ss_
#define f_get_ansorg_nbhs_em get_ansorg_nbhs_em_
#define f_get_ansorg_nbhs_ss_em get_ansorg_nbhs_ss_em_
#endif
extern "C"
{
void f_get_initial_nbhsem(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_initial_nbhsem_ss(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_ansorg_nbhs_em(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_ansorg_nbhs_ss_em(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, int &);
}
#endif /* GET_INITIAL_MAXWELL_H */

1869
AMSS_NCKU_source/Initial_Data_Solver/initial_null.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

100
AMSS_NCKU_source/Initial_Data_Solver/initial_null.h Normal file
View File

@@ -0,0 +1,100 @@
#ifndef INITIAL_NULL_H
#define INITIAL_NULL_H
#ifdef fortran1
#define f_get_initial_nbhs_null get_initial_nbhs_null
#define f_get_initial_null get_initial_null
#define f_get_exact_null get_exact_null
#define f_get_exact_null_theta get_exact_null_theta
#define f_get_null_boundary get_null_boundary
#define f_get_null_boundary_c get_null_boundary_c
#define f_get_exact_omegau get_exact_omegau
#endif
#ifdef fortran2
#define f_get_initial_nbhs_null GET_INITIAL_NBHS_NULL
#define f_get_initial_null GET_INITIAL_NULL
#define f_get_exact_null GET_EXACT_NULL
#define f_get_exact_null_theta GET_EXACT_NULL_THETA
#define f_get_null_boundary GET_NULL_BOUNDARY
#define f_get_null_boundary_c GET_NULL_BOUNDARY_C
#define f_get_exact_omegau GET_EXACT_OMEGAU
#endif
#ifdef fortran3
#define f_get_initial_nbhs_null get_initial_nbhs_null_
#define f_get_initial_null get_initial_null_
#define f_get_exact_null get_exact_null_
#define f_get_exact_null_theta get_exact_null_theta_
#define f_get_null_boundary get_null_boundary_
#define f_get_null_boundary_c get_null_boundary_c_
#define f_get_exact_omegau get_exact_omegau_
#endif
extern "C"
{
void f_get_initial_nbhs_null(int *, double *, double *, double *,
double *, double *, double *,
int &, double &);
}
extern "C"
{
void f_get_initial_null(int *, double *, double *, double *,
double *, double *,
int &, double &);
}
extern "C"
{
void f_get_null_boundary(int *, double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *,
double &, double &, int &);
}
extern "C"
{
void f_get_null_boundary_c(int *, double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *,
double &, double &, int &);
}
extern "C"
{
void f_get_exact_null(int *, double *, double *, double *,
double *, double *, int &, double &, double &,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *);
}
extern "C"
{
void f_get_exact_null_theta(int *, double *, double *, double *,
double *, double *, int &, double &, double &,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *);
}
extern "C"
{
void f_get_exact_omegau(int *, double *, double *, double *,
double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *,
double &, double &, int &);
}
#endif /* INITIAL_NULL_H */

1320
AMSS_NCKU_source/Initial_Data_Solver/initial_null2.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

98
AMSS_NCKU_source/Initial_Data_Solver/initial_null2.h Normal file
View File

@@ -0,0 +1,98 @@
#ifndef INITIAL_NULL2_H
#define INITIAL_NULL2_H
#ifdef fortran1
#define f_get_initial_null2 get_initial_null2
#define f_get_initial_null3 get_initial_null3
#define f_get_gauge_g00 get_gauge_g00
#define f_get_gauge_g00_K get_gauge_g00_k
#define f_get_gauge_g00_real get_gauge_g00_real
#define f_get_null_boundary2 get_null_boundary2
#define f_get_null_boundary3 get_null_boundary3
#define f_get_g00_with_t get_g00_with_t
#endif
#ifdef fortran2
#define f_get_initial_null2 GET_INITIAL_NULL2
#define f_get_initial_null3 GET_INITIAL_NULL3
#define f_get_gauge_g00 GET_GAUGE_G00
#define f_get_gauge_g00_K GET_GAUGE_G00_K
#define f_get_gauge_g00_real GET_GAUGE_G00_REAL
#define f_get_null_boundary2 GET_NULL_BOUNDARY2
#define f_get_null_boundary3 GET_NULL_BOUNDARY3
#define f_get_g00_with_t GET_G00_WITH_T
#endif
#ifdef fortran3
#define f_get_initial_null2 get_initial_null2_
#define f_get_initial_null3 get_initial_null3_
#define f_get_gauge_g00 get_gauge_g00_
#define f_get_gauge_g00_K get_gauge_g00_k_
#define f_get_gauge_g00_real get_gauge_g00_real_
#define f_get_null_boundary2 get_null_boundary2_
#define f_get_null_boundary3 get_null_boundary3_
#define f_get_g00_with_t get_g00_with_t_
#endif
extern "C"
{
void f_get_initial_null2(int *, double *, double *, double *,
double *, double *, double *,
int &, double &);
}
extern "C"
{
void f_get_gauge_g00(int *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *,
double *, double &, int &);
}
extern "C"
{
void f_get_gauge_g00_K(int *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *,
double *, double &);
}
extern "C"
{
void f_get_gauge_g00_real(int *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *,
double *, double &);
}
extern "C"
{
void f_get_null_boundary2(int *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, double *,
double *, double *, double *,
double &);
}
extern "C"
{
void f_get_g00_with_t(double &, int *, double *, double *, double *,
double *, double &, int &);
}
extern "C"
{
void f_get_null_boundary3(double &, int *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, double *,
double *, double *, double *,
double &, int &);
}
extern "C"
{
void f_get_initial_null3(int *, double *, double *, double *,
double *, double *, double *,
int &, double &);
}
#endif /* INITIAL_NULL2_H */

2597
AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

249
AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.h Normal file
View File

@@ -0,0 +1,249 @@
#ifndef GET_INITIAL_H
#define GET_INITIAL_H
#ifdef fortran1
#define f_get_initial_kerrschild get_initial_kerrschild
#define f_get_initial_kerrschild_ss get_initial_kerrschild_ss
#define f_get_initial_single get_initial_bssn3
#define f_get_ansorg_single get_ansorg_single
#define f_get_initial_binary get_initial_bssn6
#define f_get_ansorg_binary get_ansorg_binary
#define f_get_ansorg_nbhs get_ansorg_nbhs
#define f_get_ansorg_nbhs_escalar get_ansorg_nbhs_escalar
#define f_get_ansorg_nbhs_ss get_ansorg_nbhs_ss
#define f_get_ansorg_nbhs_ss_escalar get_ansorg_nbhs_ss_escalar
#define f_get_initial_postdeal get_initial_postdeal
#define f_get_initial_nbhs get_initial_nbhs
#define f_get_lousto_nbhs get_lousto_nbhs
#define f_get_pablo_nbhs get_pablo_nbhs
#define f_get_shapiro get_shapiro
#define f_get_niall_minkowski get_niall_minkowski
#endif
#ifdef fortran2
#define f_get_initial_kerrschild GET_INITIAL_KERRSCHILD
#define f_get_initial_kerrschild_ss GET_INITIAL_KERRSCHILD_SS
#define f_get_initial_single GET_INITIAL_BSSN3
#define f_get_ansorg_single GET_ANSORG_SINGLE
#define f_get_initial_binary GET_INITIAL_BSSN6
#define f_get_ansorg_binary GET_ANSORG_BINARY
#define f_get_ansorg_nbhs GET_ANSORG_NBHS
#define f_get_ansorg_nbhs_escalar GET_ANSORG_NBHS_ESCALAR
#define f_get_ansorg_nbhs_ss GET_ANSORG_NBHS_SS
#define f_get_ansorg_nbhs_ss_escalar GET_ANSORG_NBHS_SS_ESCALAR
#define f_get_initial_postdeal GET_INITIAL_POSTDEAL
#define f_get_initial_nbhs GET_INITIAL_NBHS
#define f_get_lousto_nbhs GET_LOUSTO_NBHS
#define f_get_pablo_nbhs GET_PABLO_NBHS
#define f_get_shapiro GET_SHAPIRO
#define f_get_niall_minkowski GRT_NIALL_MINKOWSKI
#endif
#ifdef fortran3
#define f_get_initial_kerrschild get_initial_kerrschild_
#define f_get_initial_kerrschild_ss get_initial_kerrschild_ss_
#define f_get_initial_single get_initial_bssn3_
#define f_get_ansorg_single get_ansorg_single_
#define f_get_initial_binary get_initial_bssn6_
#define f_get_ansorg_binary get_ansorg_binary_
#define f_get_ansorg_nbhs get_ansorg_nbhs_
#define f_get_ansorg_nbhs_escalar get_ansorg_nbhs_escalar_
#define f_get_ansorg_nbhs_ss get_ansorg_nbhs_ss_
#define f_get_ansorg_nbhs_ss_escalar get_ansorg_nbhs_ss_escalar_
#define f_get_initial_postdeal get_initial_postdeal_
#define f_get_initial_nbhs get_initial_nbhs_
#define f_get_lousto_nbhs get_lousto_nbhs_
#define f_get_pablo_nbhs get_pablo_nbhs_
#define f_get_shapiro get_shapiro_
#define f_get_niall_minkowski get_niall_minkowski_
#endif
extern "C"
{
void f_get_initial_kerrschild(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *);
}
extern "C"
{
void f_get_initial_kerrschild_ss(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *);
}
extern "C"
{
void f_get_initial_single(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double &, double *, double *, double *);
}
extern "C"
{
void f_get_initial_binary(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *);
}
extern "C"
{
void f_get_ansorg_single(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double &, double *, double *, double *);
}
extern "C"
{
void f_get_ansorg_binary(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *);
}
extern "C"
{
void f_get_ansorg_nbhs(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_ansorg_nbhs_ss(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_initial_postdeal(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *);
}
extern "C"
{
void f_get_lousto_nbhs(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_initial_nbhs(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_pablo_nbhs(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_shapiro(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *, int &);
}
extern "C"
{
void f_get_niall_minkowski(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *);
}
extern "C"
{
void f_get_ansorg_nbhs_escalar(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *,
double *, double *, double *, double *, int &);
}
extern "C"
{
void f_get_ansorg_nbhs_ss_escalar(int *, double *, double *, double *,
double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *, double *, double *, double *,
double *, double *, double *,
double *, double *, double *, double *,
double *, double *, double *,
double *, double *,
double *, double *, double *, double *, int &);
}
#endif /* GET_INITIAL_H */

68
AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.f90 Normal file
View File

@@ -0,0 +1,68 @@
!-----------------------------------------------------------------------------
!
! Setting initial scalar with spherical Gauss profile centered at shell r=R0
! with width WD and amplitude A
!
!-----------------------------------------------------------------------------
subroutine get_initial_scalar(ex, X, Y, Z,Sphi,Spi,R0,WD,A)
implicit none
!~~~~~~> Input parameters
integer,intent(in ):: ex(1:3)
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),R0,WD,A
real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Sphi,Spi
!~~~~~~> Local variables
real*8 :: rr
integer::i,j,k
real*8, parameter :: ZEO = 0.d0,TWO=2.d0
do k=1,ex(3)
do j=1,ex(2)
do i=1,ex(1)
rr = dsqrt(X(i)*X(i)+Y(j)*Y(j)+Z(k)*Z(k))-R0
Sphi(i,j,k) = A*dexp(-rr*rr/TWO/WD/WD)
enddo
enddo
enddo
Spi = ZEO
return
end subroutine get_initial_scalar
! for shell
subroutine get_initial_scalar_sh(ex, X, Y, Z,Sphi,Spi,R0,WD,A)
implicit none
!~~~~~~> Input parameters
integer,intent(in ):: ex(1:3)
real*8, intent(in ):: R0,WD,A
real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: X, Y, Z
real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Sphi,Spi
!~~~~~~> Local variables
real*8 :: rr
integer::i,j,k
real*8, parameter :: ZEO = 0.d0,TWO=2.d0
do k=1,ex(3)
do j=1,ex(2)
do i=1,ex(1)
rr = dsqrt(X(i,j,k)*X(i,j,k)+Y(i,j,k)*Y(i,j,k)+Z(i,j,k)*Z(i,j,k))-R0
Sphi(i,j,k) = A*dexp(-rr*rr/TWO/WD/WD)
enddo
enddo
enddo
Spi = ZEO
return
end subroutine get_initial_scalar_sh

31
AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.h Normal file
View File

@@ -0,0 +1,31 @@
#ifndef GET_INITIAL_SCALAR_H
#define GET_INITIAL_SCALAR_H
#ifdef fortran1
#define f_get_initial_scalar get_initial_scalar
#define f_get_initial_scalar_sh get_initial_scalar_sh
#endif
#ifdef fortran2
#define f_get_initial_scalar GET_INITIAL_SCALAR
#define f_get_initial_scalar_sh GET_INITIAL_SCALAR_SH
#endif
#ifdef fortran3
#define f_get_initial_scalar get_initial_scalar_
#define f_get_initial_scalar_sh get_initial_scalar_sh_
#endif
extern "C"
{
void f_get_initial_scalar(int *, double *, double *, double *,
double *, double *,
double &, double &, double &);
}
extern "C"
{
void f_get_initial_scalar_sh(int *, double *, double *, double *,
double *, double *,
double &, double &, double &);
}
#endif /* GET_INITIAL_SCALAR_H */