From 1c980c2cf1278260feb6bb9b613f8af0b22382ce Mon Sep 17 00:00:00 2001 From: knarf Date: Wed, 19 Dec 2012 15:12:36 +0000 Subject: Fix compiler warnings. Most of them could be fixed by renaming .F77 files to .F Some had to be fixed by explicitly declaring some variables using CCTK_DECLARE() (which also only works for .F, not for .F77) git-svn-id: http://svn.einsteintoolkit.org/cactus/EinsteinInitialData/Exact/trunk@287 e296648e-0e4f-0410-bd07-d597d9acff87 --- src/Bona_Masso_data.F | 748 +++++++++++++++++++++++++++ src/Bona_Masso_data.F77 | 748 --------------------------- src/blended_boundary.F | 225 ++++++++ src/blended_boundary.F77 | 225 -------- src/boost.F | 462 +++++++++++++++++ src/boost.F77 | 462 ----------------- src/boundary.F | 154 ++++++ src/boundary.F77 | 154 ------ src/decode_pars.F | 214 ++++++++ src/decode_pars.F77 | 214 -------- src/gauge.F | 187 +++++++ src/gauge.F77 | 187 ------- src/initialize.F | 161 ++++++ src/initialize.F77 | 161 ------ src/make.code.defn | 18 +- src/metric.F | 362 +++++++++++++ src/metric.F77 | 362 ------------- src/metrics/Alvi.F | 225 ++++++++ src/metrics/Alvi.F77 | 225 -------- src/metrics/Bertotti.F | 74 +++ src/metrics/Bertotti.F77 | 72 --- src/metrics/Bianchi_I.F | 74 +++ src/metrics/Bianchi_I.F77 | 71 --- src/metrics/Goedel.F | 70 +++ src/metrics/Goedel.F77 | 67 --- src/metrics/Gowdy_wave.F | 246 +++++++++ src/metrics/Gowdy_wave.F77 | 244 --------- src/metrics/Kasner_axisymmetric.F | 65 +++ src/metrics/Kasner_axisymmetric.F77 | 62 --- src/metrics/Kasner_generalized.F | 75 +++ src/metrics/Kasner_generalized.F77 | 72 --- src/metrics/Kasner_like.F | 77 +++ src/metrics/Kasner_like.F77 | 74 --- src/metrics/Kerr_BoyerLindquist.F | 68 +++ src/metrics/Kerr_BoyerLindquist.F77 | 66 --- src/metrics/Kerr_KerrSchild.F | 157 ++++++ src/metrics/Kerr_KerrSchild.F77 | 157 ------ src/metrics/Kerr_KerrSchild_spherical.F | 182 +++++++ src/metrics/Kerr_KerrSchild_spherical.F77 | 182 ------- src/metrics/Lemaitre.F | 88 ++++ src/metrics/Lemaitre.F77 | 85 --- src/metrics/Milne.F | 70 +++ src/metrics/Milne.F77 | 70 --- src/metrics/Minkowski.F | 56 ++ src/metrics/Minkowski.F77 | 53 -- src/metrics/Minkowski_conf_wave.F | 87 ++++ src/metrics/Minkowski_conf_wave.F77 | 86 --- src/metrics/Minkowski_funny.F | 114 ++++ src/metrics/Minkowski_funny.F77 | 111 ---- src/metrics/Minkowski_gauge_wave.F | 133 +++++ src/metrics/Minkowski_gauge_wave.F77 | 130 ----- src/metrics/Minkowski_shift.F | 112 ++++ src/metrics/Minkowski_shift.F77 | 111 ---- src/metrics/Minkowski_shifted_gauge_wave.F | 121 +++++ src/metrics/Minkowski_shifted_gauge_wave.F77 | 118 ----- src/metrics/Schwarzschild_BL.F | 72 +++ src/metrics/Schwarzschild_BL.F77 | 71 --- src/metrics/Schwarzschild_EF.F | 75 +++ src/metrics/Schwarzschild_EF.F77 | 74 --- src/metrics/Schwarzschild_Lemaitre.F | 80 +++ src/metrics/Schwarzschild_Lemaitre.F77 | 79 --- src/metrics/Schwarzschild_Novikov.F | 207 ++++++++ src/metrics/Schwarzschild_Novikov.F77 | 207 -------- src/metrics/Schwarzschild_PG.F | 78 +++ src/metrics/Schwarzschild_PG.F77 | 77 --- src/metrics/Thorne_fakebinary.F | 176 +++++++ src/metrics/Thorne_fakebinary.F77 | 176 ------- src/metrics/anti_de_Sitter_Lambda.F | 72 +++ src/metrics/anti_de_Sitter_Lambda.F77 | 69 --- src/metrics/boost_rotation_symmetric.F | 172 ++++++ src/metrics/boost_rotation_symmetric.F77 | 172 ------ src/metrics/bowl.F | 262 ++++++++++ src/metrics/bowl.F77 | 260 ---------- src/metrics/constant_density_star.F | 118 +++++ src/metrics/constant_density_star.F77 | 117 ----- src/metrics/de_Sitter.F | 79 +++ src/metrics/de_Sitter.F77 | 76 --- src/metrics/de_Sitter_Lambda.F | 73 +++ src/metrics/de_Sitter_Lambda.F77 | 70 --- src/metrics/make.code.defn | 64 +-- src/metrics/multi_BH.F | 141 +++++ src/metrics/multi_BH.F77 | 141 ----- src/slice_data.F | 4 +- src/xyz_blended_boundary.F | 238 +++++++++ src/xyz_blended_boundary.F77 | 238 --------- 85 files changed, 6493 insertions(+), 6439 deletions(-) create mode 100644 src/Bona_Masso_data.F delete mode 100644 src/Bona_Masso_data.F77 create mode 100644 src/blended_boundary.F delete mode 100644 src/blended_boundary.F77 create mode 100644 src/boost.F delete mode 100644 src/boost.F77 create mode 100644 src/boundary.F delete mode 100644 src/boundary.F77 create mode 100644 src/decode_pars.F delete mode 100644 src/decode_pars.F77 create mode 100644 src/gauge.F delete mode 100644 src/gauge.F77 create mode 100644 src/initialize.F delete mode 100644 src/initialize.F77 create mode 100644 src/metric.F delete mode 100644 src/metric.F77 create mode 100644 src/metrics/Alvi.F delete mode 100644 src/metrics/Alvi.F77 create mode 100644 src/metrics/Bertotti.F delete mode 100644 src/metrics/Bertotti.F77 create mode 100644 src/metrics/Bianchi_I.F delete mode 100644 src/metrics/Bianchi_I.F77 create mode 100644 src/metrics/Goedel.F delete mode 100644 src/metrics/Goedel.F77 create mode 100644 src/metrics/Gowdy_wave.F delete mode 100644 src/metrics/Gowdy_wave.F77 create mode 100644 src/metrics/Kasner_axisymmetric.F delete mode 100644 src/metrics/Kasner_axisymmetric.F77 create mode 100644 src/metrics/Kasner_generalized.F delete mode 100644 src/metrics/Kasner_generalized.F77 create mode 100644 src/metrics/Kasner_like.F delete mode 100644 src/metrics/Kasner_like.F77 create mode 100644 src/metrics/Kerr_BoyerLindquist.F delete mode 100644 src/metrics/Kerr_BoyerLindquist.F77 create mode 100644 src/metrics/Kerr_KerrSchild.F delete mode 100644 src/metrics/Kerr_KerrSchild.F77 create mode 100644 src/metrics/Kerr_KerrSchild_spherical.F delete mode 100644 src/metrics/Kerr_KerrSchild_spherical.F77 create mode 100644 src/metrics/Lemaitre.F delete mode 100644 src/metrics/Lemaitre.F77 create mode 100644 src/metrics/Milne.F delete mode 100644 src/metrics/Milne.F77 create mode 100644 src/metrics/Minkowski.F delete mode 100644 src/metrics/Minkowski.F77 create mode 100644 src/metrics/Minkowski_conf_wave.F delete mode 100644 src/metrics/Minkowski_conf_wave.F77 create mode 100644 src/metrics/Minkowski_funny.F delete mode 100644 src/metrics/Minkowski_funny.F77 create mode 100644 src/metrics/Minkowski_gauge_wave.F delete mode 100644 src/metrics/Minkowski_gauge_wave.F77 create mode 100644 src/metrics/Minkowski_shift.F delete mode 100644 src/metrics/Minkowski_shift.F77 create mode 100644 src/metrics/Minkowski_shifted_gauge_wave.F delete mode 100644 src/metrics/Minkowski_shifted_gauge_wave.F77 create mode 100644 src/metrics/Schwarzschild_BL.F delete mode 100644 src/metrics/Schwarzschild_BL.F77 create mode 100644 src/metrics/Schwarzschild_EF.F delete mode 100644 src/metrics/Schwarzschild_EF.F77 create mode 100644 src/metrics/Schwarzschild_Lemaitre.F delete mode 100644 src/metrics/Schwarzschild_Lemaitre.F77 create mode 100644 src/metrics/Schwarzschild_Novikov.F delete mode 100644 src/metrics/Schwarzschild_Novikov.F77 create mode 100644 src/metrics/Schwarzschild_PG.F delete mode 100644 src/metrics/Schwarzschild_PG.F77 create mode 100644 src/metrics/Thorne_fakebinary.F delete mode 100644 src/metrics/Thorne_fakebinary.F77 create mode 100644 src/metrics/anti_de_Sitter_Lambda.F delete mode 100644 src/metrics/anti_de_Sitter_Lambda.F77 create mode 100644 src/metrics/boost_rotation_symmetric.F delete mode 100644 src/metrics/boost_rotation_symmetric.F77 create mode 100644 src/metrics/bowl.F delete mode 100644 src/metrics/bowl.F77 create mode 100644 src/metrics/constant_density_star.F delete mode 100644 src/metrics/constant_density_star.F77 create mode 100644 src/metrics/de_Sitter.F delete mode 100644 src/metrics/de_Sitter.F77 create mode 100644 src/metrics/de_Sitter_Lambda.F delete mode 100644 src/metrics/de_Sitter_Lambda.F77 create mode 100644 src/metrics/multi_BH.F delete mode 100644 src/metrics/multi_BH.F77 create mode 100644 src/xyz_blended_boundary.F delete mode 100644 src/xyz_blended_boundary.F77 diff --git a/src/Bona_Masso_data.F b/src/Bona_Masso_data.F new file mode 100644 index 0000000..b2e36b3 --- /dev/null +++ b/src/Bona_Masso_data.F @@ -0,0 +1,748 @@ +c This routine calculates Bona-Masso initial data, making use of the +c subroutine Exact__metric() to calculate the spacetime metric and its +c inverse. Note that this use of the Bona-Masso variables is independent +c of how (or even if) we are evolving the Einstein equations -- here +c the Bona-Masso variables are "just" used as intermediate variables. + +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Bona_Masso_data( + $ decoded_exact_model, + $ x, y, z, t, + $ gxx, gyy, gzz, gxy, gyz, gxz, + $ hxx, hyy, hzz, hxy, hyz, hxz, + $ psi, psix, psiy, psiz, + $ psixx, psiyy, psizz, psixy, psiyz, psixz, + $ dxgxx, dxgyy, dxgzz, dxgxy, dxgyz, dxgxz, + $ dygxx, dygyy, dygzz, dygxy, dygyz, dygxz, + $ dzgxx, dzgyy, dzgzz, dzgxy, dzgyz, dzgxz, + $ alp, dtalp, ax, ay, az, + $ betax, betay, betaz, dtbetax, dtbetay, dtbetaz, + $ bxx, bxy, bxz, byx, byy, byz, bzx, bzy, bzz) + + implicit none + CCTK_INT decoded_exact_model + logical psi_on + CCTK_REAL x, y, z, t, + $ gxx, gyy, gzz, gxy, gyz, gxz, + $ hxx, hyy, hzz, hxy, hyz, hxz, + $ psi, psix, psiy, psiz, + $ psixx, psiyy, psizz, psixy, psiyz, psixz, + $ dxgxx, dxgyy, dxgzz, dxgxy, dxgyz, dxgxz, + $ dygxx, dygyy, dygzz, dygxy, dygyz, dygxz, + $ dzgxx, dzgyy, dzgzz, dzgxy, dzgyz, dzgxz, + $ alp, dtalp, ax, ay, az, + $ betax, betay, betaz, dtbetax, dtbetay, dtbetaz, + $ bxx, bxy, bxz, byx, byy, byz, bzx, bzy, bzz + +C gxx is g_xx etc. +C hxx is K_xx etc. +C dxgyy is (/2) dg_yy / dx (sic!) +C alp is N, betax is N^x etc. +C bxy is (/2) dN^y / dx (sic and sic!) +C ax is dN / dx / N (sic!) + + CCTK_REAL + $ gdtt, gdtx, gdty, gdtz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi + +C Save, if we have to provide the conformal factor + + psi_on = psi .gt. 0.0d0 + +C Get the spacetime metric and its inverse at the base point. + + call Exact__metric( + $ decoded_exact_model, + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gxx, gyy, gzz, gxy, gyz, gxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi) + +C Calculate lapse and shift from the upper metric. + + alp = 1.d0 / sqrt(-gutt) + + betax = - gutx / gutt + betay = - guty / gutt + betaz = - gutz / gutt + +C In order to calculate the derivatives of the lapse and shift from +C the contravariant metric, use g^tt = -1/N^2 and g^i0 = N^i / N^2 +C Note that ax is dN/dx / N and that bxy is 1/2 dN^y / dx. + +C Calculate x-derivatives. + + call Exact__metric_deriv( + $ decoded_exact_model, + $ 1, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi) + + dxgxx = 0.5d0 * dgdxx + dxgyy = 0.5d0 * dgdyy + dxgzz = 0.5d0 * dgdzz + dxgxy = 0.5d0 * dgdxy + dxgyz = 0.5d0 * dgdyz + dxgxz = 0.5d0 * dgdxz + + ax = - 0.5d0 * dgutt / gutt + + bxx = 0.5d0 * (- dgutx * gutt + gutx * dgutt) / gutt**2 + bxy = 0.5d0 * (- dguty * gutt + guty * dgutt) / gutt**2 + bxz = 0.5d0 * (- dgutz * gutt + gutz * dgutt) / gutt**2 + + if (psi_on) then + psix = dpsi + end if + +C Calculate y-derivatives. + + call Exact__metric_deriv( + $ decoded_exact_model, + $ 2, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi) + + dygxx = 0.5d0 * dgdxx + dygyy = 0.5d0 * dgdyy + dygzz = 0.5d0 * dgdzz + dygxy = 0.5d0 * dgdxy + dygyz = 0.5d0 * dgdyz + dygxz = 0.5d0 * dgdxz + + ay = - 0.5d0 * dgutt / gutt + + byx = 0.5d0 * (- dgutx * gutt + gutx * dgutt) / gutt**2 + byy = 0.5d0 * (- dguty * gutt + guty * dgutt) / gutt**2 + byz = 0.5d0 * (- dgutz * gutt + gutz * dgutt) / gutt**2 + + if (psi_on) then + psiy = dpsi + end if + +C Calculate z-derivatives. + + call Exact__metric_deriv( + $ decoded_exact_model, + $ 3, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi) + + dzgxx = 0.5d0 * dgdxx + dzgyy = 0.5d0 * dgdyy + dzgzz = 0.5d0 * dgdzz + dzgxy = 0.5d0 * dgdxy + dzgyz = 0.5d0 * dgdyz + dzgxz = 0.5d0 * dgdxz + + az = - 0.5d0 * dgutt / gutt + + bzx = 0.5d0 * (- dgutx * gutt + gutx * dgutt) / gutt**2 + bzy = 0.5d0 * (- dguty * gutt + guty * dgutt) / gutt**2 + bzz = 0.5d0 * (- dgutz * gutt + gutz * dgutt) / gutt**2 + + if (psi_on) then + psiz = dpsi + end if + +C Calculate t-derivatives, and extrinsic curvature. + + call Exact__metric_deriv( + $ decoded_exact_model, + $ 0, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi) + + hxx = - 0.5d0 * dgdxx / alp + $ + (dxgxx * betax + dygxx * betay + dzgxx * betaz + $ + 2.d0 * (bxx * gxx + bxy * gxy + bxz * gxz)) / alp + + hyy = - 0.5d0 * dgdyy / alp + $ + (dxgyy * betax + dygyy * betay + dzgyy * betaz + $ + 2.d0 * (byx * gxy + byy * gyy + byz * gyz)) / alp + + hzz = - 0.5d0 * dgdzz / alp + $ + (dxgzz * betax + dygzz * betay + dzgzz * betaz + $ + 2.d0 * (bzx * gxz + bzy * gyz + bzz * gzz)) / alp + + hxy = - 0.5d0 * dgdxy / alp + $ + (dxgxy * betax + dygxy * betay + dzgxy * betaz + $ + bxx * gxy + bxy * gyy + bxz * gyz + $ + byx * gxx + byy * gxy + byz * gxz) / alp + + hyz = - 0.5d0 * dgdyz / alp + $ + (dxgyz * betax + dygyz * betay + dzgyz * betaz + $ + byx * gxz + byy * gyz + byz * gzz + $ + bzx * gxy + bzy * gyy + bzz * gyz) / alp + + hxz = - 0.5d0 * dgdxz / alp + $ + (dxgxz * betax + dygxz * betay + dzgxz * betaz + $ + bxx * gxz + bxy * gyz + bxz * gzz + $ + bzx * gxx + bzy * gxy + bzz * gxz) / alp + +C Calculate time derivatives of lapse and shift + +C alp = 1.d0 / sqrt(-gutt) + dtalp = 0.5d0 / sqrt(-gutt)**3 * dgutt + +C betax = - gutx / gutt +C betay = - guty / gutt +C betaz = - gutz / gutt + dtbetax = (- dgutx * gutt + gutx * dgutt) / gutt**2 + dtbetay = (- dguty * gutt + guty * dgutt) / gutt**2 + dtbetaz = (- dgutz * gutt + gutz * dgutt) / gutt**2 + +C Calculate second derivatives of the conformal factor + + if (psi_on) then + call Exact__metric_deriv2( + $ decoded_exact_model, + $ 1, 1, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ psixx) + call Exact__metric_deriv2( + $ decoded_exact_model, + $ 1, 2, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ psixy) + call Exact__metric_deriv2( + $ decoded_exact_model, + $ 1, 3, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ psixz) + call Exact__metric_deriv2( + $ decoded_exact_model, + $ 2, 2, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ psiyy) + call Exact__metric_deriv2( + $ decoded_exact_model, + $ 2, 3, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ psiyz) + call Exact__metric_deriv2( + $ decoded_exact_model, + $ 3, 3, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ psizz) + + end if + return + end + + + + subroutine Exact__metric_deriv( + $ decoded_exact_model, + $ dir, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi) + + implicit none + DECLARE_CCTK_PARAMETERS + + CCTK_INT + $ decoded_exact_model, + $ dir + CCTK_REAL + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m, + $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, + $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, + $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, + $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, + $ psi_p_p, + $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, + $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, + $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, + $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, + $ psi_m_m, + $ eps, + $ dx, dy, dz, dt + + eps = exact_eps + + dx = 0 + dy = 0 + dz = 0 + dt = 0 + if (dir.eq.0) dt = eps + if (dir.eq.1) dx = eps + if (dir.eq.2) dy = eps + if (dir.eq.3) dz = eps + + if (exact_order .eq. 2) then + + call Exact__metric( + $ decoded_exact_model, + $ x-dx, y-dy, z-dz, t-dt, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m) + call Exact__metric( + $ decoded_exact_model, + $ x+dx, y+dy, z+dz, t+dt, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p) + + dgdtt = (gdtt_p - gdtt_m) / (2*eps) + dgdtx = (gdtx_p - gdtx_m) / (2*eps) + dgdty = (gdty_p - gdty_m) / (2*eps) + dgdtz = (gdtz_p - gdtz_m) / (2*eps) + dgdxx = (gdxx_p - gdxx_m) / (2*eps) + dgdyy = (gdyy_p - gdyy_m) / (2*eps) + dgdzz = (gdzz_p - gdzz_m) / (2*eps) + dgdxy = (gdxy_p - gdxy_m) / (2*eps) + dgdyz = (gdyz_p - gdyz_m) / (2*eps) + dgdxz = (gdxz_p - gdxz_m) / (2*eps) + dgutt = (gutt_p - gutt_m) / (2*eps) + dgutx = (gutx_p - gutx_m) / (2*eps) + dguty = (guty_p - guty_m) / (2*eps) + dgutz = (gutz_p - gutz_m) / (2*eps) + dguxx = (guxx_p - guxx_m) / (2*eps) + dguyy = (guyy_p - guyy_m) / (2*eps) + dguzz = (guzz_p - guzz_m) / (2*eps) + dguxy = (guxy_p - guxy_m) / (2*eps) + dguyz = (guyz_p - guyz_m) / (2*eps) + dguxz = (guxz_p - guxz_m) / (2*eps) + dpsi = (psi_p - psi_m ) / (2*eps) + + else if (exact_order .eq. 4) then + + call Exact__metric( + $ decoded_exact_model, + $ x-2*dx, y-2*dy, z-2*dz, t-2*dt, + $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, + $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, + $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, + $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, + $ psi_m_m) + call Exact__metric( + $ decoded_exact_model, + $ x-dx, y-dy, z-dz, t-dt, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m) + call Exact__metric( + $ decoded_exact_model, + $ x+dx, y+dy, z+dz, t+dt, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p) + call Exact__metric( + $ decoded_exact_model, + $ x+2*dx, y+2*dy, z+2*dz, t+2*dt, + $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, + $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, + $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, + $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, + $ psi_p_p) + + dgdtt = (- gdtt_p_p + 8*gdtt_p - 8*gdtt_m + gdtt_m_m) / (12*eps) + dgdtx = (- gdtx_p_p + 8*gdtx_p - 8*gdtx_m + gdtx_m_m) / (12*eps) + dgdty = (- gdty_p_p + 8*gdty_p - 8*gdty_m + gdty_m_m) / (12*eps) + dgdtz = (- gdtz_p_p + 8*gdtz_p - 8*gdtz_m + gdtz_m_m) / (12*eps) + dgdxx = (- gdxx_p_p + 8*gdxx_p - 8*gdxx_m + gdxx_m_m) / (12*eps) + dgdyy = (- gdyy_p_p + 8*gdyy_p - 8*gdyy_m + gdyy_m_m) / (12*eps) + dgdzz = (- gdzz_p_p + 8*gdzz_p - 8*gdzz_m + gdzz_m_m) / (12*eps) + dgdxy = (- gdxy_p_p + 8*gdxy_p - 8*gdxy_m + gdxy_m_m) / (12*eps) + dgdyz = (- gdyz_p_p + 8*gdyz_p - 8*gdyz_m + gdyz_m_m) / (12*eps) + dgdxz = (- gdxz_p_p + 8*gdxz_p - 8*gdxz_m + gdxz_m_m) / (12*eps) + dgutt = (- gutt_p_p + 8*gutt_p - 8*gutt_m + gutt_m_m) / (12*eps) + dgutx = (- gutx_p_p + 8*gutx_p - 8*gutx_m + gutx_m_m) / (12*eps) + dguty = (- guty_p_p + 8*guty_p - 8*guty_m + guty_m_m) / (12*eps) + dgutz = (- gutz_p_p + 8*gutz_p - 8*gutz_m + gutz_m_m) / (12*eps) + dguxx = (- guxx_p_p + 8*guxx_p - 8*guxx_m + guxx_m_m) / (12*eps) + dguyy = (- guyy_p_p + 8*guyy_p - 8*guyy_m + guyy_m_m) / (12*eps) + dguzz = (- guzz_p_p + 8*guzz_p - 8*guzz_m + guzz_m_m) / (12*eps) + dguxy = (- guxy_p_p + 8*guxy_p - 8*guxy_m + guxy_m_m) / (12*eps) + dguyz = (- guyz_p_p + 8*guyz_p - 8*guyz_m + guyz_m_m) / (12*eps) + dguxz = (- guxz_p_p + 8*guxz_p - 8*guxz_m + guxz_m_m) / (12*eps) + dpsi = (- psi_p_p + 8*psi_p - 8*psi_m + psi_m_m ) / (12*eps) + + else + call CCTK_WARN (CCTK_WARN_ABORT, "internal error") + end if + + end + + + + subroutine Exact__metric_deriv2( + $ decoded_exact_model, + $ dir1, dir2, + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi) + + implicit none + DECLARE_CCTK_PARAMETERS + + CCTK_INT + $ decoded_exact_model, + $ dir1, dir2 + CCTK_REAL + $ x, y, z, t, + $ dgdtt, dgdtx, dgdty, dgdtz, + $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, + $ dgutt, dgutx, dguty, dgutz, + $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, + $ dpsi, + $ gdtt_0, gdtx_0, gdty_0, gdtz_0, + $ gdxx_0, gdyy_0, gdzz_0, gdxy_0, gdyz_0, gdxz_0, + $ gutt_0, gutx_0, guty_0, gutz_0, + $ guxx_0, guyy_0, guzz_0, guxy_0, guyz_0, guxz_0, + $ psi_0, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m, + $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, + $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, + $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, + $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, + $ psi_p_p, + $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, + $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, + $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, + $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, + $ psi_m_m, + $ eps, + $ dx, dy, dz, dt + + eps = exact_eps + + dx = 0 + dy = 0 + dz = 0 + dt = 0 + if (dir1.eq.0) dt = eps + if (dir1.eq.1) dx = eps + if (dir1.eq.2) dy = eps + if (dir1.eq.3) dz = eps + if (dir1.lt.0 .or. dir1.gt.3) then + call CCTK_WARN (CCTK_WARN_ABORT, "internal error") + end if + if (dir2.lt.0 .or. dir2.gt.3) then + call CCTK_WARN (CCTK_WARN_ABORT, "internal error") + end if + + if (exact_order .eq. 2) then + + if (dir1 .eq. dir2) then + + call Exact__metric( + $ decoded_exact_model, + $ x-dx, y-dy, z-dz, t-dt, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m) + call Exact__metric( + $ decoded_exact_model, + $ x, y, z, t, + $ gdtt_0, gdtx_0, gdty_0, gdtz_0, + $ gdxx_0, gdyy_0, gdzz_0, gdxy_0, gdyz_0, gdxz_0, + $ gutt_0, gutx_0, guty_0, gutz_0, + $ guxx_0, guyy_0, guzz_0, guxy_0, guyz_0, guxz_0, + $ psi_0) + call Exact__metric( + $ decoded_exact_model, + $ x+dx, y+dy, z+dz, t+dt, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p) + + dgdtt = (gdtt_m - 2*gdtt_0 + gdtt_p) / eps**2 + dgdtx = (gdtx_m - 2*gdtx_0 + gdtx_p) / eps**2 + dgdty = (gdty_m - 2*gdty_0 + gdty_p) / eps**2 + dgdtz = (gdtz_m - 2*gdtz_0 + gdtz_p) / eps**2 + dgdxx = (gdxx_m - 2*gdxx_0 + gdxx_p) / eps**2 + dgdyy = (gdyy_m - 2*gdyy_0 + gdyy_p) / eps**2 + dgdzz = (gdzz_m - 2*gdzz_0 + gdzz_p) / eps**2 + dgdxy = (gdxy_m - 2*gdxy_0 + gdxy_p) / eps**2 + dgdyz = (gdyz_m - 2*gdyz_0 + gdyz_p) / eps**2 + dgdxz = (gdxz_m - 2*gdxz_0 + gdxz_p) / eps**2 + dgutt = (gutt_m - 2*gutt_0 + gutt_p) / eps**2 + dgutx = (gutx_m - 2*gutx_0 + gutx_p) / eps**2 + dguty = (guty_m - 2*guty_0 + guty_p) / eps**2 + dgutz = (gutz_m - 2*gutz_0 + gutz_p) / eps**2 + dguxx = (guxx_m - 2*guxx_0 + guxx_p) / eps**2 + dguyy = (guyy_m - 2*guyy_0 + guyy_p) / eps**2 + dguzz = (guzz_m - 2*guzz_0 + guzz_p) / eps**2 + dguxy = (guxy_m - 2*guxy_0 + guxy_p) / eps**2 + dguyz = (guyz_m - 2*guyz_0 + guyz_p) / eps**2 + dguxz = (guxz_m - 2*guxz_0 + guxz_p) / eps**2 + dpsi = (psi_m - 2*psi_0 + psi_p ) / eps**2 + + else + + call Exact__metric_deriv( + $ decoded_exact_model, + $ dir2, + $ x-dx, y-dy, z-dz, t-dt, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m) + call Exact__metric_deriv( + $ decoded_exact_model, + $ dir2, + $ x+dx, y+dy, z+dz, t+dt, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p) + + dgdtt = (gdtt_p - gdtt_m) / (2*eps) + dgdtx = (gdtx_p - gdtx_m) / (2*eps) + dgdty = (gdty_p - gdty_m) / (2*eps) + dgdtz = (gdtz_p - gdtz_m) / (2*eps) + dgdxx = (gdxx_p - gdxx_m) / (2*eps) + dgdyy = (gdyy_p - gdyy_m) / (2*eps) + dgdzz = (gdzz_p - gdzz_m) / (2*eps) + dgdxy = (gdxy_p - gdxy_m) / (2*eps) + dgdyz = (gdyz_p - gdyz_m) / (2*eps) + dgdxz = (gdxz_p - gdxz_m) / (2*eps) + dgutt = (gutt_p - gutt_m) / (2*eps) + dgutx = (gutx_p - gutx_m) / (2*eps) + dguty = (guty_p - guty_m) / (2*eps) + dgutz = (gutz_p - gutz_m) / (2*eps) + dguxx = (guxx_p - guxx_m) / (2*eps) + dguyy = (guyy_p - guyy_m) / (2*eps) + dguzz = (guzz_p - guzz_m) / (2*eps) + dguxy = (guxy_p - guxy_m) / (2*eps) + dguyz = (guyz_p - guyz_m) / (2*eps) + dguxz = (guxz_p - guxz_m) / (2*eps) + dpsi = (psi_p - psi_m ) / (2*eps) + + end if + + else if (exact_order .eq. 4) then + + if (dir1 .eq. dir2) then + + call Exact__metric( + $ decoded_exact_model, + $ x-2*dx, y-2*dy, z-2*dz, t-2*dt, + $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, + $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, + $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, + $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, + $ psi_m_m) + call Exact__metric( + $ decoded_exact_model, + $ x-dx, y-dy, z-dz, t-dt, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m) + call Exact__metric( + $ decoded_exact_model, + $ x, y, z, t, + $ gdtt_0, gdtx_0, gdty_0, gdtz_0, + $ gdxx_0, gdyy_0, gdzz_0, gdxy_0, gdyz_0, gdxz_0, + $ gutt_0, gutx_0, guty_0, gutz_0, + $ guxx_0, guyy_0, guzz_0, guxy_0, guyz_0, guxz_0, + $ psi_0) + call Exact__metric( + $ decoded_exact_model, + $ x+dx, y+dy, z+dz, t+dt, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p) + call Exact__metric( + $ decoded_exact_model, + $ x+2*dx, y+2*dy, z+2*dz, t+2*dt, + $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, + $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, + $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, + $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, + $ psi_p_p) + + dgdtt = (- gdtt_m_m - 16*gdtt_m + 30*gdtt_0 - 16*gdtt_p - gdtt_p_p) / (12*eps**2) + dgdtx = (- gdtx_m_m - 16*gdtx_m + 30*gdtx_0 - 16*gdtx_p - gdtx_p_p) / (12*eps**2) + dgdty = (- gdty_m_m - 16*gdty_m + 30*gdty_0 - 16*gdty_p - gdty_p_p) / (12*eps**2) + dgdtz = (- gdtz_m_m - 16*gdtz_m + 30*gdtz_0 - 16*gdtz_p - gdtz_p_p) / (12*eps**2) + dgdxx = (- gdxx_m_m - 16*gdxx_m + 30*gdxx_0 - 16*gdxx_p - gdxx_p_p) / (12*eps**2) + dgdyy = (- gdyy_m_m - 16*gdyy_m + 30*gdyy_0 - 16*gdyy_p - gdyy_p_p) / (12*eps**2) + dgdzz = (- gdzz_m_m - 16*gdzz_m + 30*gdzz_0 - 16*gdzz_p - gdzz_p_p) / (12*eps**2) + dgdxy = (- gdxy_m_m - 16*gdxy_m + 30*gdxy_0 - 16*gdxy_p - gdxy_p_p) / (12*eps**2) + dgdyz = (- gdyz_m_m - 16*gdyz_m + 30*gdyz_0 - 16*gdyz_p - gdyz_p_p) / (12*eps**2) + dgdxz = (- gdxz_m_m - 16*gdxz_m + 30*gdxz_0 - 16*gdxz_p - gdxz_p_p) / (12*eps**2) + dgutt = (- gutt_m_m - 16*gutt_m + 30*gutt_0 - 16*gutt_p - gutt_p_p) / (12*eps**2) + dgutx = (- gutx_m_m - 16*gutx_m + 30*gutx_0 - 16*gutx_p - gutx_p_p) / (12*eps**2) + dguty = (- guty_m_m - 16*guty_m + 30*guty_0 - 16*guty_p - guty_p_p) / (12*eps**2) + dgutz = (- gutz_m_m - 16*gutz_m + 30*gutz_0 - 16*gutz_p - gutz_p_p) / (12*eps**2) + dguxx = (- guxx_m_m - 16*guxx_m + 30*guxx_0 - 16*guxx_p - guxx_p_p) / (12*eps**2) + dguyy = (- guyy_m_m - 16*guyy_m + 30*guyy_0 - 16*guyy_p - guyy_p_p) / (12*eps**2) + dguzz = (- guzz_m_m - 16*guzz_m + 30*guzz_0 - 16*guzz_p - guzz_p_p) / (12*eps**2) + dguxy = (- guxy_m_m - 16*guxy_m + 30*guxy_0 - 16*guxy_p - guxy_p_p) / (12*eps**2) + dguyz = (- guyz_m_m - 16*guyz_m + 30*guyz_0 - 16*guyz_p - guyz_p_p) / (12*eps**2) + dguxz = (- guxz_m_m - 16*guxz_m + 30*guxz_0 - 16*guxz_p - guxz_p_p) / (12*eps**2) + dpsi = (- psi_m_m - 16*psi_m + 30*psi_0 - 16*psi_p - psi_p_p ) / (12*eps**2) + + else + + call Exact__metric_deriv( + $ decoded_exact_model, + $ dir2, + $ x-2*dx, y-2*dy, z-2*dz, t-2*dt, + $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, + $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, + $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, + $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, + $ psi_m_m) + call Exact__metric_deriv( + $ decoded_exact_model, + $ dir2, + $ x-dx, y-dy, z-dz, t-dt, + $ gdtt_m, gdtx_m, gdty_m, gdtz_m, + $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, + $ gutt_m, gutx_m, guty_m, gutz_m, + $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, + $ psi_m) + call Exact__metric_deriv( + $ decoded_exact_model, + $ dir2, + $ x+dx, y+dy, z+dz, t+dt, + $ gdtt_p, gdtx_p, gdty_p, gdtz_p, + $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, + $ gutt_p, gutx_p, guty_p, gutz_p, + $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, + $ psi_p) + call Exact__metric_deriv( + $ decoded_exact_model, + $ dir2, + $ x+2*dx, y+2*dy, z+2*dz, t+2*dt, + $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, + $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, + $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, + $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, + $ psi_p_p) + + dgdtt = (- gdtt_p_p + 8*gdtt_p - 8*gdtt_m + gdtt_m_m) / (12*eps) + dgdtx = (- gdtx_p_p + 8*gdtx_p - 8*gdtx_m + gdtx_m_m) / (12*eps) + dgdty = (- gdty_p_p + 8*gdty_p - 8*gdty_m + gdty_m_m) / (12*eps) + dgdtz = (- gdtz_p_p + 8*gdtz_p - 8*gdtz_m + gdtz_m_m) / (12*eps) + dgdxx = (- gdxx_p_p + 8*gdxx_p - 8*gdxx_m + gdxx_m_m) / (12*eps) + dgdyy = (- gdyy_p_p + 8*gdyy_p - 8*gdyy_m + gdyy_m_m) / (12*eps) + dgdzz = (- gdzz_p_p + 8*gdzz_p - 8*gdzz_m + gdzz_m_m) / (12*eps) + dgdxy = (- gdxy_p_p + 8*gdxy_p - 8*gdxy_m + gdxy_m_m) / (12*eps) + dgdyz = (- gdyz_p_p + 8*gdyz_p - 8*gdyz_m + gdyz_m_m) / (12*eps) + dgdxz = (- gdxz_p_p + 8*gdxz_p - 8*gdxz_m + gdxz_m_m) / (12*eps) + dgutt = (- gutt_p_p + 8*gutt_p - 8*gutt_m + gutt_m_m) / (12*eps) + dgutx = (- gutx_p_p + 8*gutx_p - 8*gutx_m + gutx_m_m) / (12*eps) + dguty = (- guty_p_p + 8*guty_p - 8*guty_m + guty_m_m) / (12*eps) + dgutz = (- gutz_p_p + 8*gutz_p - 8*gutz_m + gutz_m_m) / (12*eps) + dguxx = (- guxx_p_p + 8*guxx_p - 8*guxx_m + guxx_m_m) / (12*eps) + dguyy = (- guyy_p_p + 8*guyy_p - 8*guyy_m + guyy_m_m) / (12*eps) + dguzz = (- guzz_p_p + 8*guzz_p - 8*guzz_m + guzz_m_m) / (12*eps) + dguxy = (- guxy_p_p + 8*guxy_p - 8*guxy_m + guxy_m_m) / (12*eps) + dguyz = (- guyz_p_p + 8*guyz_p - 8*guyz_m + guyz_m_m) / (12*eps) + dguxz = (- guxz_p_p + 8*guxz_p - 8*guxz_m + guxz_m_m) / (12*eps) + dpsi = (- psi_p_p + 8*psi_p - 8*psi_m + psi_m_m ) / (12*eps) + + end if + + else + call CCTK_WARN (CCTK_WARN_ABORT, "internal error") + end if + + end diff --git a/src/Bona_Masso_data.F77 b/src/Bona_Masso_data.F77 deleted file mode 100644 index b2e36b3..0000000 --- a/src/Bona_Masso_data.F77 +++ /dev/null @@ -1,748 +0,0 @@ -c This routine calculates Bona-Masso initial data, making use of the -c subroutine Exact__metric() to calculate the spacetime metric and its -c inverse. Note that this use of the Bona-Masso variables is independent -c of how (or even if) we are evolving the Einstein equations -- here -c the Bona-Masso variables are "just" used as intermediate variables. - -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Bona_Masso_data( - $ decoded_exact_model, - $ x, y, z, t, - $ gxx, gyy, gzz, gxy, gyz, gxz, - $ hxx, hyy, hzz, hxy, hyz, hxz, - $ psi, psix, psiy, psiz, - $ psixx, psiyy, psizz, psixy, psiyz, psixz, - $ dxgxx, dxgyy, dxgzz, dxgxy, dxgyz, dxgxz, - $ dygxx, dygyy, dygzz, dygxy, dygyz, dygxz, - $ dzgxx, dzgyy, dzgzz, dzgxy, dzgyz, dzgxz, - $ alp, dtalp, ax, ay, az, - $ betax, betay, betaz, dtbetax, dtbetay, dtbetaz, - $ bxx, bxy, bxz, byx, byy, byz, bzx, bzy, bzz) - - implicit none - CCTK_INT decoded_exact_model - logical psi_on - CCTK_REAL x, y, z, t, - $ gxx, gyy, gzz, gxy, gyz, gxz, - $ hxx, hyy, hzz, hxy, hyz, hxz, - $ psi, psix, psiy, psiz, - $ psixx, psiyy, psizz, psixy, psiyz, psixz, - $ dxgxx, dxgyy, dxgzz, dxgxy, dxgyz, dxgxz, - $ dygxx, dygyy, dygzz, dygxy, dygyz, dygxz, - $ dzgxx, dzgyy, dzgzz, dzgxy, dzgyz, dzgxz, - $ alp, dtalp, ax, ay, az, - $ betax, betay, betaz, dtbetax, dtbetay, dtbetaz, - $ bxx, bxy, bxz, byx, byy, byz, bzx, bzy, bzz - -C gxx is g_xx etc. -C hxx is K_xx etc. -C dxgyy is (/2) dg_yy / dx (sic!) -C alp is N, betax is N^x etc. -C bxy is (/2) dN^y / dx (sic and sic!) -C ax is dN / dx / N (sic!) - - CCTK_REAL - $ gdtt, gdtx, gdty, gdtz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi - -C Save, if we have to provide the conformal factor - - psi_on = psi .gt. 0.0d0 - -C Get the spacetime metric and its inverse at the base point. - - call Exact__metric( - $ decoded_exact_model, - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gxx, gyy, gzz, gxy, gyz, gxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi) - -C Calculate lapse and shift from the upper metric. - - alp = 1.d0 / sqrt(-gutt) - - betax = - gutx / gutt - betay = - guty / gutt - betaz = - gutz / gutt - -C In order to calculate the derivatives of the lapse and shift from -C the contravariant metric, use g^tt = -1/N^2 and g^i0 = N^i / N^2 -C Note that ax is dN/dx / N and that bxy is 1/2 dN^y / dx. - -C Calculate x-derivatives. - - call Exact__metric_deriv( - $ decoded_exact_model, - $ 1, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi) - - dxgxx = 0.5d0 * dgdxx - dxgyy = 0.5d0 * dgdyy - dxgzz = 0.5d0 * dgdzz - dxgxy = 0.5d0 * dgdxy - dxgyz = 0.5d0 * dgdyz - dxgxz = 0.5d0 * dgdxz - - ax = - 0.5d0 * dgutt / gutt - - bxx = 0.5d0 * (- dgutx * gutt + gutx * dgutt) / gutt**2 - bxy = 0.5d0 * (- dguty * gutt + guty * dgutt) / gutt**2 - bxz = 0.5d0 * (- dgutz * gutt + gutz * dgutt) / gutt**2 - - if (psi_on) then - psix = dpsi - end if - -C Calculate y-derivatives. - - call Exact__metric_deriv( - $ decoded_exact_model, - $ 2, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi) - - dygxx = 0.5d0 * dgdxx - dygyy = 0.5d0 * dgdyy - dygzz = 0.5d0 * dgdzz - dygxy = 0.5d0 * dgdxy - dygyz = 0.5d0 * dgdyz - dygxz = 0.5d0 * dgdxz - - ay = - 0.5d0 * dgutt / gutt - - byx = 0.5d0 * (- dgutx * gutt + gutx * dgutt) / gutt**2 - byy = 0.5d0 * (- dguty * gutt + guty * dgutt) / gutt**2 - byz = 0.5d0 * (- dgutz * gutt + gutz * dgutt) / gutt**2 - - if (psi_on) then - psiy = dpsi - end if - -C Calculate z-derivatives. - - call Exact__metric_deriv( - $ decoded_exact_model, - $ 3, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi) - - dzgxx = 0.5d0 * dgdxx - dzgyy = 0.5d0 * dgdyy - dzgzz = 0.5d0 * dgdzz - dzgxy = 0.5d0 * dgdxy - dzgyz = 0.5d0 * dgdyz - dzgxz = 0.5d0 * dgdxz - - az = - 0.5d0 * dgutt / gutt - - bzx = 0.5d0 * (- dgutx * gutt + gutx * dgutt) / gutt**2 - bzy = 0.5d0 * (- dguty * gutt + guty * dgutt) / gutt**2 - bzz = 0.5d0 * (- dgutz * gutt + gutz * dgutt) / gutt**2 - - if (psi_on) then - psiz = dpsi - end if - -C Calculate t-derivatives, and extrinsic curvature. - - call Exact__metric_deriv( - $ decoded_exact_model, - $ 0, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi) - - hxx = - 0.5d0 * dgdxx / alp - $ + (dxgxx * betax + dygxx * betay + dzgxx * betaz - $ + 2.d0 * (bxx * gxx + bxy * gxy + bxz * gxz)) / alp - - hyy = - 0.5d0 * dgdyy / alp - $ + (dxgyy * betax + dygyy * betay + dzgyy * betaz - $ + 2.d0 * (byx * gxy + byy * gyy + byz * gyz)) / alp - - hzz = - 0.5d0 * dgdzz / alp - $ + (dxgzz * betax + dygzz * betay + dzgzz * betaz - $ + 2.d0 * (bzx * gxz + bzy * gyz + bzz * gzz)) / alp - - hxy = - 0.5d0 * dgdxy / alp - $ + (dxgxy * betax + dygxy * betay + dzgxy * betaz - $ + bxx * gxy + bxy * gyy + bxz * gyz - $ + byx * gxx + byy * gxy + byz * gxz) / alp - - hyz = - 0.5d0 * dgdyz / alp - $ + (dxgyz * betax + dygyz * betay + dzgyz * betaz - $ + byx * gxz + byy * gyz + byz * gzz - $ + bzx * gxy + bzy * gyy + bzz * gyz) / alp - - hxz = - 0.5d0 * dgdxz / alp - $ + (dxgxz * betax + dygxz * betay + dzgxz * betaz - $ + bxx * gxz + bxy * gyz + bxz * gzz - $ + bzx * gxx + bzy * gxy + bzz * gxz) / alp - -C Calculate time derivatives of lapse and shift - -C alp = 1.d0 / sqrt(-gutt) - dtalp = 0.5d0 / sqrt(-gutt)**3 * dgutt - -C betax = - gutx / gutt -C betay = - guty / gutt -C betaz = - gutz / gutt - dtbetax = (- dgutx * gutt + gutx * dgutt) / gutt**2 - dtbetay = (- dguty * gutt + guty * dgutt) / gutt**2 - dtbetaz = (- dgutz * gutt + gutz * dgutt) / gutt**2 - -C Calculate second derivatives of the conformal factor - - if (psi_on) then - call Exact__metric_deriv2( - $ decoded_exact_model, - $ 1, 1, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ psixx) - call Exact__metric_deriv2( - $ decoded_exact_model, - $ 1, 2, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ psixy) - call Exact__metric_deriv2( - $ decoded_exact_model, - $ 1, 3, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ psixz) - call Exact__metric_deriv2( - $ decoded_exact_model, - $ 2, 2, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ psiyy) - call Exact__metric_deriv2( - $ decoded_exact_model, - $ 2, 3, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ psiyz) - call Exact__metric_deriv2( - $ decoded_exact_model, - $ 3, 3, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ psizz) - - end if - return - end - - - - subroutine Exact__metric_deriv( - $ decoded_exact_model, - $ dir, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi) - - implicit none - DECLARE_CCTK_PARAMETERS - - CCTK_INT - $ decoded_exact_model, - $ dir - CCTK_REAL - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m, - $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, - $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, - $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, - $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, - $ psi_p_p, - $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, - $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, - $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, - $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, - $ psi_m_m, - $ eps, - $ dx, dy, dz, dt - - eps = exact_eps - - dx = 0 - dy = 0 - dz = 0 - dt = 0 - if (dir.eq.0) dt = eps - if (dir.eq.1) dx = eps - if (dir.eq.2) dy = eps - if (dir.eq.3) dz = eps - - if (exact_order .eq. 2) then - - call Exact__metric( - $ decoded_exact_model, - $ x-dx, y-dy, z-dz, t-dt, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m) - call Exact__metric( - $ decoded_exact_model, - $ x+dx, y+dy, z+dz, t+dt, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p) - - dgdtt = (gdtt_p - gdtt_m) / (2*eps) - dgdtx = (gdtx_p - gdtx_m) / (2*eps) - dgdty = (gdty_p - gdty_m) / (2*eps) - dgdtz = (gdtz_p - gdtz_m) / (2*eps) - dgdxx = (gdxx_p - gdxx_m) / (2*eps) - dgdyy = (gdyy_p - gdyy_m) / (2*eps) - dgdzz = (gdzz_p - gdzz_m) / (2*eps) - dgdxy = (gdxy_p - gdxy_m) / (2*eps) - dgdyz = (gdyz_p - gdyz_m) / (2*eps) - dgdxz = (gdxz_p - gdxz_m) / (2*eps) - dgutt = (gutt_p - gutt_m) / (2*eps) - dgutx = (gutx_p - gutx_m) / (2*eps) - dguty = (guty_p - guty_m) / (2*eps) - dgutz = (gutz_p - gutz_m) / (2*eps) - dguxx = (guxx_p - guxx_m) / (2*eps) - dguyy = (guyy_p - guyy_m) / (2*eps) - dguzz = (guzz_p - guzz_m) / (2*eps) - dguxy = (guxy_p - guxy_m) / (2*eps) - dguyz = (guyz_p - guyz_m) / (2*eps) - dguxz = (guxz_p - guxz_m) / (2*eps) - dpsi = (psi_p - psi_m ) / (2*eps) - - else if (exact_order .eq. 4) then - - call Exact__metric( - $ decoded_exact_model, - $ x-2*dx, y-2*dy, z-2*dz, t-2*dt, - $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, - $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, - $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, - $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, - $ psi_m_m) - call Exact__metric( - $ decoded_exact_model, - $ x-dx, y-dy, z-dz, t-dt, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m) - call Exact__metric( - $ decoded_exact_model, - $ x+dx, y+dy, z+dz, t+dt, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p) - call Exact__metric( - $ decoded_exact_model, - $ x+2*dx, y+2*dy, z+2*dz, t+2*dt, - $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, - $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, - $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, - $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, - $ psi_p_p) - - dgdtt = (- gdtt_p_p + 8*gdtt_p - 8*gdtt_m + gdtt_m_m) / (12*eps) - dgdtx = (- gdtx_p_p + 8*gdtx_p - 8*gdtx_m + gdtx_m_m) / (12*eps) - dgdty = (- gdty_p_p + 8*gdty_p - 8*gdty_m + gdty_m_m) / (12*eps) - dgdtz = (- gdtz_p_p + 8*gdtz_p - 8*gdtz_m + gdtz_m_m) / (12*eps) - dgdxx = (- gdxx_p_p + 8*gdxx_p - 8*gdxx_m + gdxx_m_m) / (12*eps) - dgdyy = (- gdyy_p_p + 8*gdyy_p - 8*gdyy_m + gdyy_m_m) / (12*eps) - dgdzz = (- gdzz_p_p + 8*gdzz_p - 8*gdzz_m + gdzz_m_m) / (12*eps) - dgdxy = (- gdxy_p_p + 8*gdxy_p - 8*gdxy_m + gdxy_m_m) / (12*eps) - dgdyz = (- gdyz_p_p + 8*gdyz_p - 8*gdyz_m + gdyz_m_m) / (12*eps) - dgdxz = (- gdxz_p_p + 8*gdxz_p - 8*gdxz_m + gdxz_m_m) / (12*eps) - dgutt = (- gutt_p_p + 8*gutt_p - 8*gutt_m + gutt_m_m) / (12*eps) - dgutx = (- gutx_p_p + 8*gutx_p - 8*gutx_m + gutx_m_m) / (12*eps) - dguty = (- guty_p_p + 8*guty_p - 8*guty_m + guty_m_m) / (12*eps) - dgutz = (- gutz_p_p + 8*gutz_p - 8*gutz_m + gutz_m_m) / (12*eps) - dguxx = (- guxx_p_p + 8*guxx_p - 8*guxx_m + guxx_m_m) / (12*eps) - dguyy = (- guyy_p_p + 8*guyy_p - 8*guyy_m + guyy_m_m) / (12*eps) - dguzz = (- guzz_p_p + 8*guzz_p - 8*guzz_m + guzz_m_m) / (12*eps) - dguxy = (- guxy_p_p + 8*guxy_p - 8*guxy_m + guxy_m_m) / (12*eps) - dguyz = (- guyz_p_p + 8*guyz_p - 8*guyz_m + guyz_m_m) / (12*eps) - dguxz = (- guxz_p_p + 8*guxz_p - 8*guxz_m + guxz_m_m) / (12*eps) - dpsi = (- psi_p_p + 8*psi_p - 8*psi_m + psi_m_m ) / (12*eps) - - else - call CCTK_WARN (CCTK_WARN_ABORT, "internal error") - end if - - end - - - - subroutine Exact__metric_deriv2( - $ decoded_exact_model, - $ dir1, dir2, - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi) - - implicit none - DECLARE_CCTK_PARAMETERS - - CCTK_INT - $ decoded_exact_model, - $ dir1, dir2 - CCTK_REAL - $ x, y, z, t, - $ dgdtt, dgdtx, dgdty, dgdtz, - $ dgdxx, dgdyy, dgdzz, dgdxy, dgdyz, dgdxz, - $ dgutt, dgutx, dguty, dgutz, - $ dguxx, dguyy, dguzz, dguxy, dguyz, dguxz, - $ dpsi, - $ gdtt_0, gdtx_0, gdty_0, gdtz_0, - $ gdxx_0, gdyy_0, gdzz_0, gdxy_0, gdyz_0, gdxz_0, - $ gutt_0, gutx_0, guty_0, gutz_0, - $ guxx_0, guyy_0, guzz_0, guxy_0, guyz_0, guxz_0, - $ psi_0, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m, - $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, - $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, - $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, - $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, - $ psi_p_p, - $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, - $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, - $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, - $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, - $ psi_m_m, - $ eps, - $ dx, dy, dz, dt - - eps = exact_eps - - dx = 0 - dy = 0 - dz = 0 - dt = 0 - if (dir1.eq.0) dt = eps - if (dir1.eq.1) dx = eps - if (dir1.eq.2) dy = eps - if (dir1.eq.3) dz = eps - if (dir1.lt.0 .or. dir1.gt.3) then - call CCTK_WARN (CCTK_WARN_ABORT, "internal error") - end if - if (dir2.lt.0 .or. dir2.gt.3) then - call CCTK_WARN (CCTK_WARN_ABORT, "internal error") - end if - - if (exact_order .eq. 2) then - - if (dir1 .eq. dir2) then - - call Exact__metric( - $ decoded_exact_model, - $ x-dx, y-dy, z-dz, t-dt, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m) - call Exact__metric( - $ decoded_exact_model, - $ x, y, z, t, - $ gdtt_0, gdtx_0, gdty_0, gdtz_0, - $ gdxx_0, gdyy_0, gdzz_0, gdxy_0, gdyz_0, gdxz_0, - $ gutt_0, gutx_0, guty_0, gutz_0, - $ guxx_0, guyy_0, guzz_0, guxy_0, guyz_0, guxz_0, - $ psi_0) - call Exact__metric( - $ decoded_exact_model, - $ x+dx, y+dy, z+dz, t+dt, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p) - - dgdtt = (gdtt_m - 2*gdtt_0 + gdtt_p) / eps**2 - dgdtx = (gdtx_m - 2*gdtx_0 + gdtx_p) / eps**2 - dgdty = (gdty_m - 2*gdty_0 + gdty_p) / eps**2 - dgdtz = (gdtz_m - 2*gdtz_0 + gdtz_p) / eps**2 - dgdxx = (gdxx_m - 2*gdxx_0 + gdxx_p) / eps**2 - dgdyy = (gdyy_m - 2*gdyy_0 + gdyy_p) / eps**2 - dgdzz = (gdzz_m - 2*gdzz_0 + gdzz_p) / eps**2 - dgdxy = (gdxy_m - 2*gdxy_0 + gdxy_p) / eps**2 - dgdyz = (gdyz_m - 2*gdyz_0 + gdyz_p) / eps**2 - dgdxz = (gdxz_m - 2*gdxz_0 + gdxz_p) / eps**2 - dgutt = (gutt_m - 2*gutt_0 + gutt_p) / eps**2 - dgutx = (gutx_m - 2*gutx_0 + gutx_p) / eps**2 - dguty = (guty_m - 2*guty_0 + guty_p) / eps**2 - dgutz = (gutz_m - 2*gutz_0 + gutz_p) / eps**2 - dguxx = (guxx_m - 2*guxx_0 + guxx_p) / eps**2 - dguyy = (guyy_m - 2*guyy_0 + guyy_p) / eps**2 - dguzz = (guzz_m - 2*guzz_0 + guzz_p) / eps**2 - dguxy = (guxy_m - 2*guxy_0 + guxy_p) / eps**2 - dguyz = (guyz_m - 2*guyz_0 + guyz_p) / eps**2 - dguxz = (guxz_m - 2*guxz_0 + guxz_p) / eps**2 - dpsi = (psi_m - 2*psi_0 + psi_p ) / eps**2 - - else - - call Exact__metric_deriv( - $ decoded_exact_model, - $ dir2, - $ x-dx, y-dy, z-dz, t-dt, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m) - call Exact__metric_deriv( - $ decoded_exact_model, - $ dir2, - $ x+dx, y+dy, z+dz, t+dt, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p) - - dgdtt = (gdtt_p - gdtt_m) / (2*eps) - dgdtx = (gdtx_p - gdtx_m) / (2*eps) - dgdty = (gdty_p - gdty_m) / (2*eps) - dgdtz = (gdtz_p - gdtz_m) / (2*eps) - dgdxx = (gdxx_p - gdxx_m) / (2*eps) - dgdyy = (gdyy_p - gdyy_m) / (2*eps) - dgdzz = (gdzz_p - gdzz_m) / (2*eps) - dgdxy = (gdxy_p - gdxy_m) / (2*eps) - dgdyz = (gdyz_p - gdyz_m) / (2*eps) - dgdxz = (gdxz_p - gdxz_m) / (2*eps) - dgutt = (gutt_p - gutt_m) / (2*eps) - dgutx = (gutx_p - gutx_m) / (2*eps) - dguty = (guty_p - guty_m) / (2*eps) - dgutz = (gutz_p - gutz_m) / (2*eps) - dguxx = (guxx_p - guxx_m) / (2*eps) - dguyy = (guyy_p - guyy_m) / (2*eps) - dguzz = (guzz_p - guzz_m) / (2*eps) - dguxy = (guxy_p - guxy_m) / (2*eps) - dguyz = (guyz_p - guyz_m) / (2*eps) - dguxz = (guxz_p - guxz_m) / (2*eps) - dpsi = (psi_p - psi_m ) / (2*eps) - - end if - - else if (exact_order .eq. 4) then - - if (dir1 .eq. dir2) then - - call Exact__metric( - $ decoded_exact_model, - $ x-2*dx, y-2*dy, z-2*dz, t-2*dt, - $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, - $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, - $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, - $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, - $ psi_m_m) - call Exact__metric( - $ decoded_exact_model, - $ x-dx, y-dy, z-dz, t-dt, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m) - call Exact__metric( - $ decoded_exact_model, - $ x, y, z, t, - $ gdtt_0, gdtx_0, gdty_0, gdtz_0, - $ gdxx_0, gdyy_0, gdzz_0, gdxy_0, gdyz_0, gdxz_0, - $ gutt_0, gutx_0, guty_0, gutz_0, - $ guxx_0, guyy_0, guzz_0, guxy_0, guyz_0, guxz_0, - $ psi_0) - call Exact__metric( - $ decoded_exact_model, - $ x+dx, y+dy, z+dz, t+dt, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p) - call Exact__metric( - $ decoded_exact_model, - $ x+2*dx, y+2*dy, z+2*dz, t+2*dt, - $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, - $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, - $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, - $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, - $ psi_p_p) - - dgdtt = (- gdtt_m_m - 16*gdtt_m + 30*gdtt_0 - 16*gdtt_p - gdtt_p_p) / (12*eps**2) - dgdtx = (- gdtx_m_m - 16*gdtx_m + 30*gdtx_0 - 16*gdtx_p - gdtx_p_p) / (12*eps**2) - dgdty = (- gdty_m_m - 16*gdty_m + 30*gdty_0 - 16*gdty_p - gdty_p_p) / (12*eps**2) - dgdtz = (- gdtz_m_m - 16*gdtz_m + 30*gdtz_0 - 16*gdtz_p - gdtz_p_p) / (12*eps**2) - dgdxx = (- gdxx_m_m - 16*gdxx_m + 30*gdxx_0 - 16*gdxx_p - gdxx_p_p) / (12*eps**2) - dgdyy = (- gdyy_m_m - 16*gdyy_m + 30*gdyy_0 - 16*gdyy_p - gdyy_p_p) / (12*eps**2) - dgdzz = (- gdzz_m_m - 16*gdzz_m + 30*gdzz_0 - 16*gdzz_p - gdzz_p_p) / (12*eps**2) - dgdxy = (- gdxy_m_m - 16*gdxy_m + 30*gdxy_0 - 16*gdxy_p - gdxy_p_p) / (12*eps**2) - dgdyz = (- gdyz_m_m - 16*gdyz_m + 30*gdyz_0 - 16*gdyz_p - gdyz_p_p) / (12*eps**2) - dgdxz = (- gdxz_m_m - 16*gdxz_m + 30*gdxz_0 - 16*gdxz_p - gdxz_p_p) / (12*eps**2) - dgutt = (- gutt_m_m - 16*gutt_m + 30*gutt_0 - 16*gutt_p - gutt_p_p) / (12*eps**2) - dgutx = (- gutx_m_m - 16*gutx_m + 30*gutx_0 - 16*gutx_p - gutx_p_p) / (12*eps**2) - dguty = (- guty_m_m - 16*guty_m + 30*guty_0 - 16*guty_p - guty_p_p) / (12*eps**2) - dgutz = (- gutz_m_m - 16*gutz_m + 30*gutz_0 - 16*gutz_p - gutz_p_p) / (12*eps**2) - dguxx = (- guxx_m_m - 16*guxx_m + 30*guxx_0 - 16*guxx_p - guxx_p_p) / (12*eps**2) - dguyy = (- guyy_m_m - 16*guyy_m + 30*guyy_0 - 16*guyy_p - guyy_p_p) / (12*eps**2) - dguzz = (- guzz_m_m - 16*guzz_m + 30*guzz_0 - 16*guzz_p - guzz_p_p) / (12*eps**2) - dguxy = (- guxy_m_m - 16*guxy_m + 30*guxy_0 - 16*guxy_p - guxy_p_p) / (12*eps**2) - dguyz = (- guyz_m_m - 16*guyz_m + 30*guyz_0 - 16*guyz_p - guyz_p_p) / (12*eps**2) - dguxz = (- guxz_m_m - 16*guxz_m + 30*guxz_0 - 16*guxz_p - guxz_p_p) / (12*eps**2) - dpsi = (- psi_m_m - 16*psi_m + 30*psi_0 - 16*psi_p - psi_p_p ) / (12*eps**2) - - else - - call Exact__metric_deriv( - $ decoded_exact_model, - $ dir2, - $ x-2*dx, y-2*dy, z-2*dz, t-2*dt, - $ gdtt_m_m, gdtx_m_m, gdty_m_m, gdtz_m_m, - $ gdxx_m_m, gdyy_m_m, gdzz_m_m, gdxy_m_m, gdyz_m_m, gdxz_m_m, - $ gutt_m_m, gutx_m_m, guty_m_m, gutz_m_m, - $ guxx_m_m, guyy_m_m, guzz_m_m, guxy_m_m, guyz_m_m, guxz_m_m, - $ psi_m_m) - call Exact__metric_deriv( - $ decoded_exact_model, - $ dir2, - $ x-dx, y-dy, z-dz, t-dt, - $ gdtt_m, gdtx_m, gdty_m, gdtz_m, - $ gdxx_m, gdyy_m, gdzz_m, gdxy_m, gdyz_m, gdxz_m, - $ gutt_m, gutx_m, guty_m, gutz_m, - $ guxx_m, guyy_m, guzz_m, guxy_m, guyz_m, guxz_m, - $ psi_m) - call Exact__metric_deriv( - $ decoded_exact_model, - $ dir2, - $ x+dx, y+dy, z+dz, t+dt, - $ gdtt_p, gdtx_p, gdty_p, gdtz_p, - $ gdxx_p, gdyy_p, gdzz_p, gdxy_p, gdyz_p, gdxz_p, - $ gutt_p, gutx_p, guty_p, gutz_p, - $ guxx_p, guyy_p, guzz_p, guxy_p, guyz_p, guxz_p, - $ psi_p) - call Exact__metric_deriv( - $ decoded_exact_model, - $ dir2, - $ x+2*dx, y+2*dy, z+2*dz, t+2*dt, - $ gdtt_p_p, gdtx_p_p, gdty_p_p, gdtz_p_p, - $ gdxx_p_p, gdyy_p_p, gdzz_p_p, gdxy_p_p, gdyz_p_p, gdxz_p_p, - $ gutt_p_p, gutx_p_p, guty_p_p, gutz_p_p, - $ guxx_p_p, guyy_p_p, guzz_p_p, guxy_p_p, guyz_p_p, guxz_p_p, - $ psi_p_p) - - dgdtt = (- gdtt_p_p + 8*gdtt_p - 8*gdtt_m + gdtt_m_m) / (12*eps) - dgdtx = (- gdtx_p_p + 8*gdtx_p - 8*gdtx_m + gdtx_m_m) / (12*eps) - dgdty = (- gdty_p_p + 8*gdty_p - 8*gdty_m + gdty_m_m) / (12*eps) - dgdtz = (- gdtz_p_p + 8*gdtz_p - 8*gdtz_m + gdtz_m_m) / (12*eps) - dgdxx = (- gdxx_p_p + 8*gdxx_p - 8*gdxx_m + gdxx_m_m) / (12*eps) - dgdyy = (- gdyy_p_p + 8*gdyy_p - 8*gdyy_m + gdyy_m_m) / (12*eps) - dgdzz = (- gdzz_p_p + 8*gdzz_p - 8*gdzz_m + gdzz_m_m) / (12*eps) - dgdxy = (- gdxy_p_p + 8*gdxy_p - 8*gdxy_m + gdxy_m_m) / (12*eps) - dgdyz = (- gdyz_p_p + 8*gdyz_p - 8*gdyz_m + gdyz_m_m) / (12*eps) - dgdxz = (- gdxz_p_p + 8*gdxz_p - 8*gdxz_m + gdxz_m_m) / (12*eps) - dgutt = (- gutt_p_p + 8*gutt_p - 8*gutt_m + gutt_m_m) / (12*eps) - dgutx = (- gutx_p_p + 8*gutx_p - 8*gutx_m + gutx_m_m) / (12*eps) - dguty = (- guty_p_p + 8*guty_p - 8*guty_m + guty_m_m) / (12*eps) - dgutz = (- gutz_p_p + 8*gutz_p - 8*gutz_m + gutz_m_m) / (12*eps) - dguxx = (- guxx_p_p + 8*guxx_p - 8*guxx_m + guxx_m_m) / (12*eps) - dguyy = (- guyy_p_p + 8*guyy_p - 8*guyy_m + guyy_m_m) / (12*eps) - dguzz = (- guzz_p_p + 8*guzz_p - 8*guzz_m + guzz_m_m) / (12*eps) - dguxy = (- guxy_p_p + 8*guxy_p - 8*guxy_m + guxy_m_m) / (12*eps) - dguyz = (- guyz_p_p + 8*guyz_p - 8*guyz_m + guyz_m_m) / (12*eps) - dguxz = (- guxz_p_p + 8*guxz_p - 8*guxz_m + guxz_m_m) / (12*eps) - dpsi = (- psi_p_p + 8*psi_p - 8*psi_m + psi_m_m ) / (12*eps) - - end if - - else - call CCTK_WARN (CCTK_WARN_ABORT, "internal error") - end if - - end diff --git a/src/blended_boundary.F b/src/blended_boundary.F new file mode 100644 index 0000000..c46623c --- /dev/null +++ b/src/blended_boundary.F @@ -0,0 +1,225 @@ +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + + subroutine Exact__blended_boundary(CCTK_ARGUMENTS) + + implicit none + + DECLARE_CCTK_ARGUMENTS + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + + logical doKij, doGij, doLapse, doShift + + integer i,j,k + integer nx,ny,nz + + CCTK_REAL router, rinner, frac, onemfrac + CCTK_REAL gxxe, gyye, gzze, gxye, gyze, gxze + CCTK_REAL kxxe, kyye, kzze, kxye, kyze, kxze + CCTK_REAL dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze + CCTK_REAL dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze + CCTK_REAL dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze + + CCTK_REAL + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz + + CCTK_REAL alpe, dtalpe, axe, aye, aze + CCTK_REAL betaxe,betaye,betaze, dtbetaxe,dtbetaye,dtbetaze + CCTK_REAL bxxe,bxye,bxze,byxe,byye,byze,bzxe,bzye,bzze + + CCTK_REAL det, uxx, uxy, uxz, uyy, uyz, uzz + + CCTK_REAL dx,dy,dz,time + CCTK_REAL xmx,xmn,ymx,ymn,zmx,zmn,rmx + integer ierr + +C Grid parameters. + + nx = cctk_lsh(1) + ny = cctk_lsh(2) + nz = cctk_lsh(3) + + dx = cctk_delta_space(1) + dy = cctk_delta_space(2) + dz = cctk_delta_space(3) + + time = cctk_time + +C Other parameters. + + doKij = (exblend_Ks.eq.1) + doGij = (exblend_gs.eq.1) + + doLapse = ((exblend_gauge.eq.1).and. + $ (CCTK_Equals(lapse_evolution_method,"exact").ne.0)) + doShift = ((exblend_gauge.eq.1).and. + $ (CCTK_Equals(shift_evolution_method,"exact").ne.0)) + + call CCTK_CoordRange(ierr,cctkGH,xmn,xmx,-1,"x","cart3d") + call CCTK_CoordRange(ierr,cctkGH,ymn,ymx,-1,"y","cart3d") + call CCTK_CoordRange(ierr,cctkGH,zmn,zmx,-1,"z","cart3d") + + rmx = min(xmx,ymx,zmx) + + if (exblend_rout.lt.0) then + router = rmx - 2.0d0*dx + else + router = exblend_rout + endif + + if (exblend_width.lt.0) then + rinner = router + exblend_width*dx + else + rinner = router - exblend_width + endif + + do k=1,nz + do j=1,ny + do i=1,nx + +c We only do anything if r >= rinner so only evaluate exact data +c there. + + if (r(i,j,k) .ge. rinner) then + +C Initialize the psi of exact +C (also to tell the models about the conformal_state) + if (conformal_state .ne. 0) then + exact_psi = 1.0D0 + else + exact_psi = 0.0D0 + end if + exact_psix = 0.0D0 + exact_psiy = 0.0D0 + exact_psiz = 0.0D0 + exact_psixx = 0.0D0 + exact_psiyy = 0.0D0 + exact_psizz = 0.0D0 + exact_psixy = 0.0D0 + exact_psiyz = 0.0D0 + exact_psixz = 0.0D0 + + call Exact__Bona_Masso_data( + $ decoded_exact_model, + $ x(i,j,k), y(i,j,k), z(i,j,k), time, + $ gxxe, gyye, gzze, gxye, gyze, gxze, + $ kxxe, kyye, kzze, kxye, kyze, kxze, + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz, + $ dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze, + $ dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze, + $ dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze, + $ alpe, dtalpe, axe, aye, aze, + $ betaxe, betaye, betaze, dtbetaxe, dtbetaye, dtbetaze, + $ bxxe, bxye, bxze, byxe, + $ byye, byze, bzxe, bzye, bzze) + +c This sucks, but we want the exact vs so we can blend them also. + + det = -(gxze**2*gyye) + & + 2.d0*gxye*gxze*gyze + & - gxxe*gyze**2 + & - gxye**2*gzze + & + gxxe*gyye*gzze + + uxx=(-gyze**2 + gyye*gzze)/det + uxy=(gxze*gyze - gxye*gzze)/det + uyy=(-gxze**2 + gxxe*gzze)/det + uxz=(-gxze*gyye + gxye*gyze)/det + uyz=(gxye*gxze - gxxe*gyze)/det + uzz=(-gxye**2 + gxxe*gyye)/det + +c Outside of router we want to place exact data on our grid + + if (r(i,j,k) .gt. router) then + +c This is one of those things I will invariably screw up if I type +c it in so let the computer do it + +#define exassign(q) q(i,j,k) = q e +#define exassign_grp(p) \ + exassign(p xx) &&\ + exassign(p xy) &&\ + exassign(p xz) &&\ + exassign(p yy) &&\ + exassign(p yz) &&\ + exassign(p zz) + +c Note this plays on the nasty trick that fortran doesnt give a +c damn about spaces so gxx e is the same as gxxe for the parser... +c Grody but effective! + + if (doGij) then + exassign_grp(g) + endif + if (doKij) then + exassign_grp(k) + endif + + if (doLapse) then + exassign(alp) + endif + + if (doShift.and.(shift_state.ne.0)) then + exassign(betax) + exassign(betay) + exassign(betaz) + endif + +c OK so we dont want to blend so use a goto to jump. + else + +c Evaluate the linear weighting fraction. Obvious... + + frac = (r(i,j,k) - rinner) / (router - rinner) + onemfrac = 1.0D0 - frac + +c Once again some c-preprocessor tricks based on the whole fortran +c space thing... + +#define INTPOINT(f,v) f(i,j,k) = frac * v + onemfrac * f(i,j,k) +#define intone(f) INTPOINT(f, f e) +#define int_grp(p) \ + intone(p xx) &&\ + intone(p xy) &&\ + intone(p xz) &&\ + intone(p yy) &&\ + intone(p yz) &&\ + intone(p zz) + + if (doGij) then + int_grp(g) + endif + if (doKij) then + int_grp(k) + endif + + if (doLapse) then + intone(alp) + endif + + if (doShift.and.(shift_state.ne.0)) then + intone(betax) + intone(betay) + intone(betaz) + endif + + endif ! r > router else + endif ! r > rinner + + enddo + enddo + enddo + + return + end diff --git a/src/blended_boundary.F77 b/src/blended_boundary.F77 deleted file mode 100644 index c46623c..0000000 --- a/src/blended_boundary.F77 +++ /dev/null @@ -1,225 +0,0 @@ -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - - subroutine Exact__blended_boundary(CCTK_ARGUMENTS) - - implicit none - - DECLARE_CCTK_ARGUMENTS - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - - logical doKij, doGij, doLapse, doShift - - integer i,j,k - integer nx,ny,nz - - CCTK_REAL router, rinner, frac, onemfrac - CCTK_REAL gxxe, gyye, gzze, gxye, gyze, gxze - CCTK_REAL kxxe, kyye, kzze, kxye, kyze, kxze - CCTK_REAL dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze - CCTK_REAL dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze - CCTK_REAL dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze - - CCTK_REAL - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz - - CCTK_REAL alpe, dtalpe, axe, aye, aze - CCTK_REAL betaxe,betaye,betaze, dtbetaxe,dtbetaye,dtbetaze - CCTK_REAL bxxe,bxye,bxze,byxe,byye,byze,bzxe,bzye,bzze - - CCTK_REAL det, uxx, uxy, uxz, uyy, uyz, uzz - - CCTK_REAL dx,dy,dz,time - CCTK_REAL xmx,xmn,ymx,ymn,zmx,zmn,rmx - integer ierr - -C Grid parameters. - - nx = cctk_lsh(1) - ny = cctk_lsh(2) - nz = cctk_lsh(3) - - dx = cctk_delta_space(1) - dy = cctk_delta_space(2) - dz = cctk_delta_space(3) - - time = cctk_time - -C Other parameters. - - doKij = (exblend_Ks.eq.1) - doGij = (exblend_gs.eq.1) - - doLapse = ((exblend_gauge.eq.1).and. - $ (CCTK_Equals(lapse_evolution_method,"exact").ne.0)) - doShift = ((exblend_gauge.eq.1).and. - $ (CCTK_Equals(shift_evolution_method,"exact").ne.0)) - - call CCTK_CoordRange(ierr,cctkGH,xmn,xmx,-1,"x","cart3d") - call CCTK_CoordRange(ierr,cctkGH,ymn,ymx,-1,"y","cart3d") - call CCTK_CoordRange(ierr,cctkGH,zmn,zmx,-1,"z","cart3d") - - rmx = min(xmx,ymx,zmx) - - if (exblend_rout.lt.0) then - router = rmx - 2.0d0*dx - else - router = exblend_rout - endif - - if (exblend_width.lt.0) then - rinner = router + exblend_width*dx - else - rinner = router - exblend_width - endif - - do k=1,nz - do j=1,ny - do i=1,nx - -c We only do anything if r >= rinner so only evaluate exact data -c there. - - if (r(i,j,k) .ge. rinner) then - -C Initialize the psi of exact -C (also to tell the models about the conformal_state) - if (conformal_state .ne. 0) then - exact_psi = 1.0D0 - else - exact_psi = 0.0D0 - end if - exact_psix = 0.0D0 - exact_psiy = 0.0D0 - exact_psiz = 0.0D0 - exact_psixx = 0.0D0 - exact_psiyy = 0.0D0 - exact_psizz = 0.0D0 - exact_psixy = 0.0D0 - exact_psiyz = 0.0D0 - exact_psixz = 0.0D0 - - call Exact__Bona_Masso_data( - $ decoded_exact_model, - $ x(i,j,k), y(i,j,k), z(i,j,k), time, - $ gxxe, gyye, gzze, gxye, gyze, gxze, - $ kxxe, kyye, kzze, kxye, kyze, kxze, - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz, - $ dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze, - $ dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze, - $ dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze, - $ alpe, dtalpe, axe, aye, aze, - $ betaxe, betaye, betaze, dtbetaxe, dtbetaye, dtbetaze, - $ bxxe, bxye, bxze, byxe, - $ byye, byze, bzxe, bzye, bzze) - -c This sucks, but we want the exact vs so we can blend them also. - - det = -(gxze**2*gyye) - & + 2.d0*gxye*gxze*gyze - & - gxxe*gyze**2 - & - gxye**2*gzze - & + gxxe*gyye*gzze - - uxx=(-gyze**2 + gyye*gzze)/det - uxy=(gxze*gyze - gxye*gzze)/det - uyy=(-gxze**2 + gxxe*gzze)/det - uxz=(-gxze*gyye + gxye*gyze)/det - uyz=(gxye*gxze - gxxe*gyze)/det - uzz=(-gxye**2 + gxxe*gyye)/det - -c Outside of router we want to place exact data on our grid - - if (r(i,j,k) .gt. router) then - -c This is one of those things I will invariably screw up if I type -c it in so let the computer do it - -#define exassign(q) q(i,j,k) = q e -#define exassign_grp(p) \ - exassign(p xx) &&\ - exassign(p xy) &&\ - exassign(p xz) &&\ - exassign(p yy) &&\ - exassign(p yz) &&\ - exassign(p zz) - -c Note this plays on the nasty trick that fortran doesnt give a -c damn about spaces so gxx e is the same as gxxe for the parser... -c Grody but effective! - - if (doGij) then - exassign_grp(g) - endif - if (doKij) then - exassign_grp(k) - endif - - if (doLapse) then - exassign(alp) - endif - - if (doShift.and.(shift_state.ne.0)) then - exassign(betax) - exassign(betay) - exassign(betaz) - endif - -c OK so we dont want to blend so use a goto to jump. - else - -c Evaluate the linear weighting fraction. Obvious... - - frac = (r(i,j,k) - rinner) / (router - rinner) - onemfrac = 1.0D0 - frac - -c Once again some c-preprocessor tricks based on the whole fortran -c space thing... - -#define INTPOINT(f,v) f(i,j,k) = frac * v + onemfrac * f(i,j,k) -#define intone(f) INTPOINT(f, f e) -#define int_grp(p) \ - intone(p xx) &&\ - intone(p xy) &&\ - intone(p xz) &&\ - intone(p yy) &&\ - intone(p yz) &&\ - intone(p zz) - - if (doGij) then - int_grp(g) - endif - if (doKij) then - int_grp(k) - endif - - if (doLapse) then - intone(alp) - endif - - if (doShift.and.(shift_state.ne.0)) then - intone(betax) - intone(betay) - intone(betaz) - endif - - endif ! r > router else - endif ! r > rinner - - enddo - enddo - enddo - - return - end diff --git a/src/boost.F b/src/boost.F new file mode 100644 index 0000000..6b993ea --- /dev/null +++ b/src/boost.F @@ -0,0 +1,462 @@ +c This subroutine calculates the 4-metric and its inverse at an event, +c taking into account an optional Lorentz boost and an optional rotation. +c The model is first rotated and then boosted, such that the boost is +c applied to the rotated model. +c $Header$ +c +c The coordinates are +c Cx(a) = Cactus $x^a$ +c Mx(a) = Model $X^a$ +c The 4-metrics are +c Cgdd(a,b) = Cactus $g_{ab}$ Cguu(a,b) = Cactus $g^{ab}$ +c Mgdd(a,b) = Model $g_{ab}$ Mguu(a,b) = Model $g^{ab}$ +c +c For a definition of the Euler angles in the conventions used below, see +c http://mathworld.wolfram.com/EulerAngles.html +c Another useful resource may be +c http://en.wikipedia.org/wiki/Euler_angles +c although this uses (on 2006-11-29) different conventions. +c +c This file is copyright (c) 2003 by Jonathan Thornburg . +c This file is covered by the GNU GPL license; see the files ../README +c and ../COPYING for details. +c + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + +#include "param_defs.inc" + + subroutine Exact__metric( + $ decoded_exact_model, + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi) + + implicit none + DECLARE_CCTK_FUNCTIONS + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_INT decoded_exact_model + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi + +c static local variables describing Lorentz transformation + logical firstcall + data firstcall /.true./ + CCTK_REAL gamma + CCTK_REAL vv(3), nn(3) + CCTK_REAL parallel(3,3), perp(3,3) + CCTK_REAL Cx_par(3), Cx_perp(3) + CCTK_REAL partial_Mx_wrt_Cx(0:3,0:3) + CCTK_REAL partial_Cx_wrt_Mx(0:3,0:3) + CCTK_REAL R(0:3,0:3) + save firstcall + save gamma + save vv + save parallel, perp + save partial_Mx_wrt_Cx + save partial_Cx_wrt_Mx + save R +c$omp threadprivate (firstcall, gamma, vv, parallel, perp, +c$omp+ partial_Mx_wrt_Cx,partial_Cx_wrt_Mx, R) + +c coordinates and 4-metric + CCTK_REAL Cx(0:3) + CCTK_REAL Cgdd(0:3,0:3), Cguu(0:3,0:3) + CCTK_REAL Mx(0:3) + CCTK_REAL Mgdd(0:3,0:3), Mguu(0:3,0:3) + CCTK_REAL Nx(0:3) + CCTK_REAL Ngdd(0:3,0:3), Nguu(0:3,0:3) + +c misc temps + CCTK_REAL vnorm, vnormsq + CCTK_REAL delta_ij + CCTK_REAL Cx_par_i, Cx_perp_i + CCTK_REAL vdotCx + CCTK_REAL Cgdd_ab, Cguu_ab + CCTK_REAL cos_phi, sin_phi + CCTK_REAL cos_theta, sin_theta + CCTK_REAL cos_psi, sin_psi + CCTK_REAL R_phi(0:3,0:3), R_theta(0:3,0:3), R_psi(0:3,0:3) + character*1000 warn_buffer + +c flags, array indices, etc + logical Tmunu_flag + integer i, j, k, l + integer Ca, Cb, MA, MB + +c constants + integer n + parameter (n = 3) + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c optimized fast-path if no Lorentz boost and no rotation +c + if ( (boost_vx .eq. 0.0) + $ .and. (boost_vy .eq. 0.0) + $ .and. (boost_vz .eq. 0.0) + $ .and. (rotation_euler_phi .eq. 0.0) + $ .and. (rotation_euler_theta .eq. 0.0) + $ .and. (rotation_euler_psi .eq. 0.0)) then + call Exact__metric_for_model( + $ decoded_exact_model, + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, + $ Tmunu_flag) + return + end if + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c the rest of this function is the Lorentz-boost case: +c - Lorentz-transform Cactus coordinates --> Model coordinates +c - compute Model 4-metric and inverse at Model coordinates +c - tensor-transform 4-metric and inverse from Model coordinates +c --> Cactus coordinates +c +c All the equations used are given in ../doc/documentation.tex +c + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c compute Lorentz transformation information on first call +c + if (firstcall) then + +c boost velocity + vv(1) = boost_vx + vv(2) = boost_vy + vv(3) = boost_vz + +c Lorentz gamma factor, unit vector in direction of boost velocity + vnormsq = 0.0 + do i = 1,n + vnormsq = vnormsq + vv(i)*vv(i) + end do + gamma = 1.0 / sqrt(1.0 - vnormsq) + vnorm = sqrt(vnormsq) + if ( (boost_vx .eq. 0.0) + $ .and. (boost_vy .eq. 0.0) + $ .and. (boost_vz .eq. 0.0)) then + nn(1) = 1 + nn(2) = 0 + nn(3) = 0 + else + do i = 1,n + nn(i) = vv(i) / vnorm + end do + end if + +c projection operators parallel(*,*) and perp(*,*) + do j = 1,n + do i = 1,n + parallel(i,j) = nn(i) * nn(j) + if (i .eq. j) then + delta_ij = 1.0 + else + delta_ij = 0.0 + end if + perp(i,j) = delta_ij - parallel(i,j) + end do + end do + +c partial derivatives of Model coordinates with respect to Cactus coordinates + partial_Mx_wrt_Cx(0,0) = gamma + do i = 1,n + partial_Mx_wrt_Cx(0,i) = -gamma*vv(i) + end do + do i = 1,n + partial_Mx_wrt_Cx(i,0) = -gamma*vv(i) + do j=1,n + partial_Mx_wrt_Cx(i,j) = gamma*parallel(i,j) + perp(i,j) + end do + end do + +c partial derivatives of Cactus coordinates with respect to Model coordinates + partial_Cx_wrt_Mx(0,0) = gamma + do i = 1,n + partial_Cx_wrt_Mx(0,i) = + gamma*vv(i) + end do + do i = 1,n + partial_Cx_wrt_Mx(i,0) = + gamma*vv(i) + do j=1,n + partial_Cx_wrt_Mx(i,j) = gamma*parallel(i,j) + perp(i,j) + end do + end do + +c Sines and cosines of rotation angles + cos_phi = cos (rotation_euler_phi) + sin_phi = sin (rotation_euler_phi) + cos_theta = cos (rotation_euler_theta) + sin_theta = sin (rotation_euler_theta) + cos_psi = cos (rotation_euler_psi) + sin_psi = sin (rotation_euler_psi) + +c Set up individual rotation matrices + R_phi(0,0) = 1 + R_phi(0,1) = 0 + R_phi(0,2) = 0 + R_phi(0,3) = 0 + R_phi(1,0) = 0 + R_phi(1,1) = + cos_phi + R_phi(1,2) = + sin_phi + R_phi(1,3) = 0 + R_phi(2,0) = 0 + R_phi(2,1) = - sin_phi + R_phi(2,2) = + cos_phi + R_phi(2,3) = 0 + R_phi(3,0) = 0 + R_phi(3,1) = 0 + R_phi(3,2) = 0 + R_phi(3,3) = 1 + + R_theta(0,0) = 1 + R_theta(0,1) = 0 + R_theta(0,2) = 0 + R_theta(0,3) = 0 + R_theta(1,0) = 0 + R_theta(1,1) = 1 + R_theta(1,2) = 0 + R_theta(1,3) = 0 + R_theta(2,0) = 0 + R_theta(2,1) = 0 + R_theta(2,2) = + cos_theta + R_theta(2,3) = + sin_theta + R_theta(3,0) = 0 + R_theta(3,1) = 0 + R_theta(3,2) = - sin_theta + R_theta(3,3) = + cos_theta + + R_psi(0,0) = 1 + R_psi(0,1) = 0 + R_psi(0,2) = 0 + R_psi(0,3) = 0 + R_psi(1,0) = 0 + R_psi(1,1) = + cos_psi + R_psi(1,2) = + sin_psi + R_psi(1,3) = 0 + R_psi(2,0) = 0 + R_psi(2,1) = - sin_psi + R_psi(2,2) = + cos_psi + R_psi(2,3) = 0 + R_psi(3,0) = 0 + R_psi(3,1) = 0 + R_psi(3,2) = 0 + R_psi(3,3) = 1 + +c Combine individual rotation matrices + do i = 0,n + do j = 0,n + R(i,j) = 0 + do k = 0,n + do l = 0,n + R(i,j) = R(i,j) + R_psi(i,k) * R_theta(k,l) * R_phi(l,j) + end do + end do + end do + end do + +c Notes that help me (Erik Schnetter) think: +c This considers a rotation with phi=0, theta=pi/2, psi=0. +c Nx(i) = Nx(i) + R(j,i) * Mx(j) +c Nx(1) = - Mx(3) +c Nx(3) = Mx(1) +c Mgxx(1,1) = Ngxx(3,3) +c Mgxx(1,3) = - Ngxx(1,3) +c Mgxx(3,3) = Ngxx(1,1) +c Mgxx(i,j) = R(i,k) R(j,l) Ngxx(k,l) [correct] +c Mgxx(i,j) = R(k,i) R(l,j) Ngxx(k,l) [correct] +c Mbetax(1) = - Nbetax(3) +c Mbetax(3) = Nbetax(1) +c Mbetax(i) + R(i,j) Nbetax(j) [wrong] +c Mbetax(i) + R(j,i) Nbetax(j) [correct] + + firstcall = .false. + end if + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c compute flat-space components of Cx(*) parallel and perpendicular to vv(*) +c + Cx(0) = t + Cx(1) = x + Cx(2) = y + Cx(3) = z + + do i=1,n + Cx_par_i = 0.0 + Cx_perp_i = 0.0 + do j=1,n + Cx_par_i = Cx_par_i + parallel(i,j)*Cx(j) + Cx_perp_i = Cx_perp_i + perp (i,j)*Cx(j) + end do + Cx_par (i) = Cx_par_i + Cx_perp(i) = Cx_perp_i + end do + +c +c Lorentz-transform and rotate the Cactus coordinate +c to get the Model coordinates +c + +c Boost + vdotCx = 0.0 + do i = 1,n + vdotCx = vdotCx + vv(i)*Cx(i) + end do + + Mx(0) = gamma * (Cx(0) - vdotCx) + do i=1,n + Mx(i) = gamma * (Cx_par(i) - vv(i)*Cx(0)) + Cx_perp(i) + end do + +c Rotation + do i=0,n + Nx(i) = 0 + do j = 0,n + Nx(i) = Nx(i) + R(i,j) * Mx(j) + end do + end do + + +c +c compute the Model 4-metric and inverse 4-metric at the Model coordinates +c + call Exact__metric_for_model( + $ decoded_exact_model, + $ Nx(1), Nx(2), Nx(3), Nx(0), + $ Ngdd(0,0), Ngdd(0,1), Ngdd(0,2), Ngdd(0,3), + $ Ngdd(1,1), Ngdd(2,2), Ngdd(3,3), + $ Ngdd(1,2), Ngdd(2,3), Ngdd(1,3), + $ Nguu(0,0), Nguu(0,1), Nguu(0,2), Nguu(0,3), + $ Nguu(1,1), Nguu(2,2), Nguu(3,3), + $ Nguu(1,2), Nguu(2,3), Nguu(1,3), + $ psi, Tmunu_flag) + + if (Tmunu_flag) then + write (warn_buffer, '(a,i8,a,a)') + $ 'exact_model = ', decoded_exact_model, + $ 'sets the stress-energy tensor', + $ ' ==> we cannot Lorentz-boost or rotate it!' + call CCTK_WARN(0, warn_buffer) + end if + +c +c symmetrize the Model 4-metric and inverse 4-metric arrays +c (the Exact__metric_for_model() call only set the upper triangles) +c + Ngdd(1,0) = Ngdd(0,1) + Ngdd(2,0) = Ngdd(0,2) + Ngdd(2,1) = Ngdd(1,2) + Ngdd(3,0) = Ngdd(0,3) + Ngdd(3,1) = Ngdd(1,3) + Ngdd(3,2) = Ngdd(2,3) + + Nguu(1,0) = Nguu(0,1) + Nguu(2,0) = Nguu(0,2) + Nguu(2,1) = Nguu(1,2) + Nguu(3,0) = Nguu(0,3) + Nguu(3,1) = Nguu(1,3) + Nguu(3,2) = Nguu(2,3) + +c +c tensor-transorm (the upper triangle of) the 4-metric and inverse 4-metric +c + +c Rotations + do i = 0,n + do j = 0,n + Mgdd(i,j) = 0 + Mguu(i,j) = 0 + do k = 0,n + do l = 0,n + Mgdd(i,j) = Mgdd(i,j) + R(k,i) * R(l,j) * Ngdd(k,l) +c The inverse of R is also its transpose. That means that the +c transpose of the inverse, which you would use for g^ij, is just R +c again. + Mguu(i,j) = Mguu(i,j) + R(k,i) * R(l,j) * Nguu(k,l) + end do + end do + end do + end do + +c Boost + do Ca = 0,n + do Cb = Ca,n + Cgdd_ab = 0.0 + do Ma = 0,n + do Mb = 0,n + Cgdd_ab = Cgdd_ab + $ + Mgdd(Ma,Mb) + $ * partial_Mx_wrt_Cx(Ma,Ca) + $ * partial_Mx_wrt_Cx(Mb,Cb) + end do + end do + Cgdd(Ca,Cb) = Cgdd_ab + end do + end do + + do Ca = 0,n + do Cb = Ca,n + Cguu_ab = 0.0 + do Ma = 0,n + do Mb = 0,n + Cguu_ab = Cguu_ab + $ + Mguu(Ma,Mb) + $ * partial_Cx_wrt_Mx(Ca,Ma) + $ * partial_Cx_wrt_Mx(Cb,Mb) + end do + end do + Cguu(Ca,Cb) = Cguu_ab + end do + end do + +c +c unpack the Cactus-coordinates 4-metric and inverse 4-metric +c into the corresponding output arguments +c + gdtt = Cgdd(0,0) + gdtx = Cgdd(0,1) + gdty = Cgdd(0,2) + gdtz = Cgdd(0,3) + gdxx = Cgdd(1,1) + gdxy = Cgdd(1,2) + gdxz = Cgdd(1,3) + gdyy = Cgdd(2,2) + gdyz = Cgdd(2,3) + gdzz = Cgdd(3,3) + + gutt = Cguu(0,0) + gutx = Cguu(0,1) + guty = Cguu(0,2) + gutz = Cguu(0,3) + guxx = Cguu(1,1) + guxy = Cguu(1,2) + guxz = Cguu(1,3) + guyy = Cguu(2,2) + guyz = Cguu(2,3) + guzz = Cguu(3,3) + + end diff --git a/src/boost.F77 b/src/boost.F77 deleted file mode 100644 index 6b993ea..0000000 --- a/src/boost.F77 +++ /dev/null @@ -1,462 +0,0 @@ -c This subroutine calculates the 4-metric and its inverse at an event, -c taking into account an optional Lorentz boost and an optional rotation. -c The model is first rotated and then boosted, such that the boost is -c applied to the rotated model. -c $Header$ -c -c The coordinates are -c Cx(a) = Cactus $x^a$ -c Mx(a) = Model $X^a$ -c The 4-metrics are -c Cgdd(a,b) = Cactus $g_{ab}$ Cguu(a,b) = Cactus $g^{ab}$ -c Mgdd(a,b) = Model $g_{ab}$ Mguu(a,b) = Model $g^{ab}$ -c -c For a definition of the Euler angles in the conventions used below, see -c http://mathworld.wolfram.com/EulerAngles.html -c Another useful resource may be -c http://en.wikipedia.org/wiki/Euler_angles -c although this uses (on 2006-11-29) different conventions. -c -c This file is copyright (c) 2003 by Jonathan Thornburg . -c This file is covered by the GNU GPL license; see the files ../README -c and ../COPYING for details. -c - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - -#include "param_defs.inc" - - subroutine Exact__metric( - $ decoded_exact_model, - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi) - - implicit none - DECLARE_CCTK_FUNCTIONS - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_INT decoded_exact_model - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi - -c static local variables describing Lorentz transformation - logical firstcall - data firstcall /.true./ - CCTK_REAL gamma - CCTK_REAL vv(3), nn(3) - CCTK_REAL parallel(3,3), perp(3,3) - CCTK_REAL Cx_par(3), Cx_perp(3) - CCTK_REAL partial_Mx_wrt_Cx(0:3,0:3) - CCTK_REAL partial_Cx_wrt_Mx(0:3,0:3) - CCTK_REAL R(0:3,0:3) - save firstcall - save gamma - save vv - save parallel, perp - save partial_Mx_wrt_Cx - save partial_Cx_wrt_Mx - save R -c$omp threadprivate (firstcall, gamma, vv, parallel, perp, -c$omp+ partial_Mx_wrt_Cx,partial_Cx_wrt_Mx, R) - -c coordinates and 4-metric - CCTK_REAL Cx(0:3) - CCTK_REAL Cgdd(0:3,0:3), Cguu(0:3,0:3) - CCTK_REAL Mx(0:3) - CCTK_REAL Mgdd(0:3,0:3), Mguu(0:3,0:3) - CCTK_REAL Nx(0:3) - CCTK_REAL Ngdd(0:3,0:3), Nguu(0:3,0:3) - -c misc temps - CCTK_REAL vnorm, vnormsq - CCTK_REAL delta_ij - CCTK_REAL Cx_par_i, Cx_perp_i - CCTK_REAL vdotCx - CCTK_REAL Cgdd_ab, Cguu_ab - CCTK_REAL cos_phi, sin_phi - CCTK_REAL cos_theta, sin_theta - CCTK_REAL cos_psi, sin_psi - CCTK_REAL R_phi(0:3,0:3), R_theta(0:3,0:3), R_psi(0:3,0:3) - character*1000 warn_buffer - -c flags, array indices, etc - logical Tmunu_flag - integer i, j, k, l - integer Ca, Cb, MA, MB - -c constants - integer n - parameter (n = 3) - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c optimized fast-path if no Lorentz boost and no rotation -c - if ( (boost_vx .eq. 0.0) - $ .and. (boost_vy .eq. 0.0) - $ .and. (boost_vz .eq. 0.0) - $ .and. (rotation_euler_phi .eq. 0.0) - $ .and. (rotation_euler_theta .eq. 0.0) - $ .and. (rotation_euler_psi .eq. 0.0)) then - call Exact__metric_for_model( - $ decoded_exact_model, - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, - $ Tmunu_flag) - return - end if - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c the rest of this function is the Lorentz-boost case: -c - Lorentz-transform Cactus coordinates --> Model coordinates -c - compute Model 4-metric and inverse at Model coordinates -c - tensor-transform 4-metric and inverse from Model coordinates -c --> Cactus coordinates -c -c All the equations used are given in ../doc/documentation.tex -c - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c compute Lorentz transformation information on first call -c - if (firstcall) then - -c boost velocity - vv(1) = boost_vx - vv(2) = boost_vy - vv(3) = boost_vz - -c Lorentz gamma factor, unit vector in direction of boost velocity - vnormsq = 0.0 - do i = 1,n - vnormsq = vnormsq + vv(i)*vv(i) - end do - gamma = 1.0 / sqrt(1.0 - vnormsq) - vnorm = sqrt(vnormsq) - if ( (boost_vx .eq. 0.0) - $ .and. (boost_vy .eq. 0.0) - $ .and. (boost_vz .eq. 0.0)) then - nn(1) = 1 - nn(2) = 0 - nn(3) = 0 - else - do i = 1,n - nn(i) = vv(i) / vnorm - end do - end if - -c projection operators parallel(*,*) and perp(*,*) - do j = 1,n - do i = 1,n - parallel(i,j) = nn(i) * nn(j) - if (i .eq. j) then - delta_ij = 1.0 - else - delta_ij = 0.0 - end if - perp(i,j) = delta_ij - parallel(i,j) - end do - end do - -c partial derivatives of Model coordinates with respect to Cactus coordinates - partial_Mx_wrt_Cx(0,0) = gamma - do i = 1,n - partial_Mx_wrt_Cx(0,i) = -gamma*vv(i) - end do - do i = 1,n - partial_Mx_wrt_Cx(i,0) = -gamma*vv(i) - do j=1,n - partial_Mx_wrt_Cx(i,j) = gamma*parallel(i,j) + perp(i,j) - end do - end do - -c partial derivatives of Cactus coordinates with respect to Model coordinates - partial_Cx_wrt_Mx(0,0) = gamma - do i = 1,n - partial_Cx_wrt_Mx(0,i) = + gamma*vv(i) - end do - do i = 1,n - partial_Cx_wrt_Mx(i,0) = + gamma*vv(i) - do j=1,n - partial_Cx_wrt_Mx(i,j) = gamma*parallel(i,j) + perp(i,j) - end do - end do - -c Sines and cosines of rotation angles - cos_phi = cos (rotation_euler_phi) - sin_phi = sin (rotation_euler_phi) - cos_theta = cos (rotation_euler_theta) - sin_theta = sin (rotation_euler_theta) - cos_psi = cos (rotation_euler_psi) - sin_psi = sin (rotation_euler_psi) - -c Set up individual rotation matrices - R_phi(0,0) = 1 - R_phi(0,1) = 0 - R_phi(0,2) = 0 - R_phi(0,3) = 0 - R_phi(1,0) = 0 - R_phi(1,1) = + cos_phi - R_phi(1,2) = + sin_phi - R_phi(1,3) = 0 - R_phi(2,0) = 0 - R_phi(2,1) = - sin_phi - R_phi(2,2) = + cos_phi - R_phi(2,3) = 0 - R_phi(3,0) = 0 - R_phi(3,1) = 0 - R_phi(3,2) = 0 - R_phi(3,3) = 1 - - R_theta(0,0) = 1 - R_theta(0,1) = 0 - R_theta(0,2) = 0 - R_theta(0,3) = 0 - R_theta(1,0) = 0 - R_theta(1,1) = 1 - R_theta(1,2) = 0 - R_theta(1,3) = 0 - R_theta(2,0) = 0 - R_theta(2,1) = 0 - R_theta(2,2) = + cos_theta - R_theta(2,3) = + sin_theta - R_theta(3,0) = 0 - R_theta(3,1) = 0 - R_theta(3,2) = - sin_theta - R_theta(3,3) = + cos_theta - - R_psi(0,0) = 1 - R_psi(0,1) = 0 - R_psi(0,2) = 0 - R_psi(0,3) = 0 - R_psi(1,0) = 0 - R_psi(1,1) = + cos_psi - R_psi(1,2) = + sin_psi - R_psi(1,3) = 0 - R_psi(2,0) = 0 - R_psi(2,1) = - sin_psi - R_psi(2,2) = + cos_psi - R_psi(2,3) = 0 - R_psi(3,0) = 0 - R_psi(3,1) = 0 - R_psi(3,2) = 0 - R_psi(3,3) = 1 - -c Combine individual rotation matrices - do i = 0,n - do j = 0,n - R(i,j) = 0 - do k = 0,n - do l = 0,n - R(i,j) = R(i,j) + R_psi(i,k) * R_theta(k,l) * R_phi(l,j) - end do - end do - end do - end do - -c Notes that help me (Erik Schnetter) think: -c This considers a rotation with phi=0, theta=pi/2, psi=0. -c Nx(i) = Nx(i) + R(j,i) * Mx(j) -c Nx(1) = - Mx(3) -c Nx(3) = Mx(1) -c Mgxx(1,1) = Ngxx(3,3) -c Mgxx(1,3) = - Ngxx(1,3) -c Mgxx(3,3) = Ngxx(1,1) -c Mgxx(i,j) = R(i,k) R(j,l) Ngxx(k,l) [correct] -c Mgxx(i,j) = R(k,i) R(l,j) Ngxx(k,l) [correct] -c Mbetax(1) = - Nbetax(3) -c Mbetax(3) = Nbetax(1) -c Mbetax(i) + R(i,j) Nbetax(j) [wrong] -c Mbetax(i) + R(j,i) Nbetax(j) [correct] - - firstcall = .false. - end if - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c compute flat-space components of Cx(*) parallel and perpendicular to vv(*) -c - Cx(0) = t - Cx(1) = x - Cx(2) = y - Cx(3) = z - - do i=1,n - Cx_par_i = 0.0 - Cx_perp_i = 0.0 - do j=1,n - Cx_par_i = Cx_par_i + parallel(i,j)*Cx(j) - Cx_perp_i = Cx_perp_i + perp (i,j)*Cx(j) - end do - Cx_par (i) = Cx_par_i - Cx_perp(i) = Cx_perp_i - end do - -c -c Lorentz-transform and rotate the Cactus coordinate -c to get the Model coordinates -c - -c Boost - vdotCx = 0.0 - do i = 1,n - vdotCx = vdotCx + vv(i)*Cx(i) - end do - - Mx(0) = gamma * (Cx(0) - vdotCx) - do i=1,n - Mx(i) = gamma * (Cx_par(i) - vv(i)*Cx(0)) + Cx_perp(i) - end do - -c Rotation - do i=0,n - Nx(i) = 0 - do j = 0,n - Nx(i) = Nx(i) + R(i,j) * Mx(j) - end do - end do - - -c -c compute the Model 4-metric and inverse 4-metric at the Model coordinates -c - call Exact__metric_for_model( - $ decoded_exact_model, - $ Nx(1), Nx(2), Nx(3), Nx(0), - $ Ngdd(0,0), Ngdd(0,1), Ngdd(0,2), Ngdd(0,3), - $ Ngdd(1,1), Ngdd(2,2), Ngdd(3,3), - $ Ngdd(1,2), Ngdd(2,3), Ngdd(1,3), - $ Nguu(0,0), Nguu(0,1), Nguu(0,2), Nguu(0,3), - $ Nguu(1,1), Nguu(2,2), Nguu(3,3), - $ Nguu(1,2), Nguu(2,3), Nguu(1,3), - $ psi, Tmunu_flag) - - if (Tmunu_flag) then - write (warn_buffer, '(a,i8,a,a)') - $ 'exact_model = ', decoded_exact_model, - $ 'sets the stress-energy tensor', - $ ' ==> we cannot Lorentz-boost or rotate it!' - call CCTK_WARN(0, warn_buffer) - end if - -c -c symmetrize the Model 4-metric and inverse 4-metric arrays -c (the Exact__metric_for_model() call only set the upper triangles) -c - Ngdd(1,0) = Ngdd(0,1) - Ngdd(2,0) = Ngdd(0,2) - Ngdd(2,1) = Ngdd(1,2) - Ngdd(3,0) = Ngdd(0,3) - Ngdd(3,1) = Ngdd(1,3) - Ngdd(3,2) = Ngdd(2,3) - - Nguu(1,0) = Nguu(0,1) - Nguu(2,0) = Nguu(0,2) - Nguu(2,1) = Nguu(1,2) - Nguu(3,0) = Nguu(0,3) - Nguu(3,1) = Nguu(1,3) - Nguu(3,2) = Nguu(2,3) - -c -c tensor-transorm (the upper triangle of) the 4-metric and inverse 4-metric -c - -c Rotations - do i = 0,n - do j = 0,n - Mgdd(i,j) = 0 - Mguu(i,j) = 0 - do k = 0,n - do l = 0,n - Mgdd(i,j) = Mgdd(i,j) + R(k,i) * R(l,j) * Ngdd(k,l) -c The inverse of R is also its transpose. That means that the -c transpose of the inverse, which you would use for g^ij, is just R -c again. - Mguu(i,j) = Mguu(i,j) + R(k,i) * R(l,j) * Nguu(k,l) - end do - end do - end do - end do - -c Boost - do Ca = 0,n - do Cb = Ca,n - Cgdd_ab = 0.0 - do Ma = 0,n - do Mb = 0,n - Cgdd_ab = Cgdd_ab - $ + Mgdd(Ma,Mb) - $ * partial_Mx_wrt_Cx(Ma,Ca) - $ * partial_Mx_wrt_Cx(Mb,Cb) - end do - end do - Cgdd(Ca,Cb) = Cgdd_ab - end do - end do - - do Ca = 0,n - do Cb = Ca,n - Cguu_ab = 0.0 - do Ma = 0,n - do Mb = 0,n - Cguu_ab = Cguu_ab - $ + Mguu(Ma,Mb) - $ * partial_Cx_wrt_Mx(Ca,Ma) - $ * partial_Cx_wrt_Mx(Cb,Mb) - end do - end do - Cguu(Ca,Cb) = Cguu_ab - end do - end do - -c -c unpack the Cactus-coordinates 4-metric and inverse 4-metric -c into the corresponding output arguments -c - gdtt = Cgdd(0,0) - gdtx = Cgdd(0,1) - gdty = Cgdd(0,2) - gdtz = Cgdd(0,3) - gdxx = Cgdd(1,1) - gdxy = Cgdd(1,2) - gdxz = Cgdd(1,3) - gdyy = Cgdd(2,2) - gdyz = Cgdd(2,3) - gdzz = Cgdd(3,3) - - gutt = Cguu(0,0) - gutx = Cguu(0,1) - guty = Cguu(0,2) - gutz = Cguu(0,3) - guxx = Cguu(1,1) - guxy = Cguu(1,2) - guxz = Cguu(1,3) - guyy = Cguu(2,2) - guyz = Cguu(2,3) - guzz = Cguu(3,3) - - end diff --git a/src/boundary.F b/src/boundary.F new file mode 100644 index 0000000..644d6a5 --- /dev/null +++ b/src/boundary.F @@ -0,0 +1,154 @@ +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + + subroutine Exact__boundary(CCTK_ARGUMENTS) + + implicit none + + DECLARE_CCTK_ARGUMENTS + + integer i,j,k + integer nx,ny,nz + + CCTK_REAL tplusone + CCTK_REAL + $ dxgxxjunk, dxgyyjunk, dxgzzjunk, + $ dxgxyjunk, dxgyzjunk, dxgxzjunk, + $ dygxxjunk, dygyyjunk, dygzzjunk, + $ dygxyjunk, dygyzjunk, dygxzjunk, + $ dzgxxjunk, dzgyyjunk, dzgzzjunk, + $ dzgxyjunk, dzgyzjunk, dzgxzjunk, + $ axjunk, ayjunk, azjunk, + $ bxxjunk, bxyjunk, bxzjunk, + $ byxjunk, byyjunk, byzjunk, + $ bzxjunk, bzyjunk, bzzjunk + CCTK_REAL + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz + +C Grid parameters. + + nx = cctk_lsh(1) + ny = cctk_lsh(2) + nz = cctk_lsh(3) + +C Initialize the psi of exact +C (also to tell the models about the conformal_state) + if (conformal_state .ne. 0) then + exact_psi = 1.0D0 + else + exact_psi = 0.0D0 + end if + exact_psix = 0.0D0 + exact_psiy = 0.0D0 + exact_psiz = 0.0D0 + exact_psixx = 0.0D0 + exact_psiyy = 0.0D0 + exact_psizz = 0.0D0 + exact_psixy = 0.0D0 + exact_psiyz = 0.0D0 + exact_psixz = 0.0D0 + +C Set all initial data including dijk and vi on all points which +C are on the boundary of the domain if it really is the boundary +C of the complete grid. Treat all six sides of the grid cube this way. + +c Set t = time + dt. This is necessary here because by the time +c we reach this point the geometry has been evolved one time step +c but the variable `time' still hasn't been updated. + + tplusone = cctk_time + cctk_delta_time + +C Note we also always set the lapse and shift at the boundaries at +C time t+1. This is to provide boundary conditions for testing +C elliptic gauge conditions. If they are not used, they will be +C overwritten by Exact__gauge. + +#define EXACTDATAPOINT \ + call Exact__Bona_Masso_data( \ + decoded_exact_model, \ + x(i,j,k), y(i,j,k), z(i,j,k), tplusone, \ + gxx(i,j,k), gyy(i,j,k), gzz(i,j,k), \ + gxy(i,j,k), gyz(i,j,k), gxz(i,j,k), \ + kxx(i,j,k), kyy(i,j,k), kzz(i,j,k), \ + kxy(i,j,k), kyz(i,j,k), kxz(i,j,k), \ + exact_psi, \ + exact_psix, exact_psiy, exact_psiz, \ + exact_psixx, exact_psiyy, exact_psizz, \ + exact_psixy, exact_psiyz, exact_psixz, \ + dxgxxjunk, dxgyyjunk, dxgzzjunk, \ + dxgxyjunk, dxgyzjunk, dxgxzjunk, \ + dygxxjunk, dygyyjunk, dygzzjunk, \ + dygxyjunk, dygyzjunk, dygxzjunk, \ + dzgxxjunk, dzgyyjunk, dzgzzjunk, \ + dzgxyjunk, dzgyzjunk, dzgxzjunk, \ + alp(i,j,k), dtalp(i,j,k), \ + axjunk, ayjunk, azjunk, \ + betax(i,j,k), betay(i,j,k), betaz(i,j,k), \ + dtbetax(i,j,k), dtbetay(i,j,k), dtbetaz(i,j,k), \ + bxxjunk, bxyjunk, bxzjunk, \ + byxjunk, byyjunk, byzjunk, \ + bzxjunk, bzyjunk, bzzjunk) + + if (cctk_bbox(1) .eq. 1) then + i=1 + do j=1,ny + do k=1,nz + EXACTDATAPOINT + end do + end do + end if + + if (cctk_bbox(2) .eq. 1) then + i=nx + do j=1,ny + do k=1,nz + EXACTDATAPOINT + end do + end do + end if + + if (cctk_bbox(3) .eq. 1) then + j=1 + do i=1,nx + do k=1,nz + EXACTDATAPOINT + end do + end do + end if + + if (cctk_bbox(4) .eq. 1) then + j=ny + do i=1,nx + do k=1,nz + EXACTDATAPOINT + end do + end do + end if + + if (cctk_bbox(5) .eq. 1) then + k=1 + do j=1,ny + do i=1,nx + EXACTDATAPOINT + end do + end do + end if + + if (cctk_bbox(6) .eq. 1) then + k=nz + do j=1,ny + do i=1,nx + EXACTDATAPOINT + end do + end do + end if + + return + end diff --git a/src/boundary.F77 b/src/boundary.F77 deleted file mode 100644 index 644d6a5..0000000 --- a/src/boundary.F77 +++ /dev/null @@ -1,154 +0,0 @@ -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - - subroutine Exact__boundary(CCTK_ARGUMENTS) - - implicit none - - DECLARE_CCTK_ARGUMENTS - - integer i,j,k - integer nx,ny,nz - - CCTK_REAL tplusone - CCTK_REAL - $ dxgxxjunk, dxgyyjunk, dxgzzjunk, - $ dxgxyjunk, dxgyzjunk, dxgxzjunk, - $ dygxxjunk, dygyyjunk, dygzzjunk, - $ dygxyjunk, dygyzjunk, dygxzjunk, - $ dzgxxjunk, dzgyyjunk, dzgzzjunk, - $ dzgxyjunk, dzgyzjunk, dzgxzjunk, - $ axjunk, ayjunk, azjunk, - $ bxxjunk, bxyjunk, bxzjunk, - $ byxjunk, byyjunk, byzjunk, - $ bzxjunk, bzyjunk, bzzjunk - CCTK_REAL - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz - -C Grid parameters. - - nx = cctk_lsh(1) - ny = cctk_lsh(2) - nz = cctk_lsh(3) - -C Initialize the psi of exact -C (also to tell the models about the conformal_state) - if (conformal_state .ne. 0) then - exact_psi = 1.0D0 - else - exact_psi = 0.0D0 - end if - exact_psix = 0.0D0 - exact_psiy = 0.0D0 - exact_psiz = 0.0D0 - exact_psixx = 0.0D0 - exact_psiyy = 0.0D0 - exact_psizz = 0.0D0 - exact_psixy = 0.0D0 - exact_psiyz = 0.0D0 - exact_psixz = 0.0D0 - -C Set all initial data including dijk and vi on all points which -C are on the boundary of the domain if it really is the boundary -C of the complete grid. Treat all six sides of the grid cube this way. - -c Set t = time + dt. This is necessary here because by the time -c we reach this point the geometry has been evolved one time step -c but the variable `time' still hasn't been updated. - - tplusone = cctk_time + cctk_delta_time - -C Note we also always set the lapse and shift at the boundaries at -C time t+1. This is to provide boundary conditions for testing -C elliptic gauge conditions. If they are not used, they will be -C overwritten by Exact__gauge. - -#define EXACTDATAPOINT \ - call Exact__Bona_Masso_data( \ - decoded_exact_model, \ - x(i,j,k), y(i,j,k), z(i,j,k), tplusone, \ - gxx(i,j,k), gyy(i,j,k), gzz(i,j,k), \ - gxy(i,j,k), gyz(i,j,k), gxz(i,j,k), \ - kxx(i,j,k), kyy(i,j,k), kzz(i,j,k), \ - kxy(i,j,k), kyz(i,j,k), kxz(i,j,k), \ - exact_psi, \ - exact_psix, exact_psiy, exact_psiz, \ - exact_psixx, exact_psiyy, exact_psizz, \ - exact_psixy, exact_psiyz, exact_psixz, \ - dxgxxjunk, dxgyyjunk, dxgzzjunk, \ - dxgxyjunk, dxgyzjunk, dxgxzjunk, \ - dygxxjunk, dygyyjunk, dygzzjunk, \ - dygxyjunk, dygyzjunk, dygxzjunk, \ - dzgxxjunk, dzgyyjunk, dzgzzjunk, \ - dzgxyjunk, dzgyzjunk, dzgxzjunk, \ - alp(i,j,k), dtalp(i,j,k), \ - axjunk, ayjunk, azjunk, \ - betax(i,j,k), betay(i,j,k), betaz(i,j,k), \ - dtbetax(i,j,k), dtbetay(i,j,k), dtbetaz(i,j,k), \ - bxxjunk, bxyjunk, bxzjunk, \ - byxjunk, byyjunk, byzjunk, \ - bzxjunk, bzyjunk, bzzjunk) - - if (cctk_bbox(1) .eq. 1) then - i=1 - do j=1,ny - do k=1,nz - EXACTDATAPOINT - end do - end do - end if - - if (cctk_bbox(2) .eq. 1) then - i=nx - do j=1,ny - do k=1,nz - EXACTDATAPOINT - end do - end do - end if - - if (cctk_bbox(3) .eq. 1) then - j=1 - do i=1,nx - do k=1,nz - EXACTDATAPOINT - end do - end do - end if - - if (cctk_bbox(4) .eq. 1) then - j=ny - do i=1,nx - do k=1,nz - EXACTDATAPOINT - end do - end do - end if - - if (cctk_bbox(5) .eq. 1) then - k=1 - do j=1,ny - do i=1,nx - EXACTDATAPOINT - end do - end do - end if - - if (cctk_bbox(6) .eq. 1) then - k=nz - do j=1,ny - do i=1,nx - EXACTDATAPOINT - end do - end do - end if - - return - end diff --git a/src/decode_pars.F b/src/decode_pars.F new file mode 100644 index 0000000..d51bb4a --- /dev/null +++ b/src/decode_pars.F @@ -0,0 +1,214 @@ +c/*@@ +c @file decode_pars.F +c @date Fri Jun 7 19:47:46 CEST 2002 +c @author Jonathan Thornburg +c @desc +c Decode/copy parameters for this thorn into grid scalars +c so we can share this with friends +c so the Calc_Tmunu code in ../include/Scalar_CalcTmunu.inc +c can use them in computing the stress-energy tensor +c +c Actually we only have to copy those parameters which are +c used by the Calc_Tmunu code. For simplicity we decode +c exact_model into the integer decoded_exact_model, then +c copy only the per-model parameters for those models which +c have stress-energy tensor code in ../include/Scalar_CalcTmunu.inc . +c +c @enddesc +c @version $Header$ +c@@*/ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + +#include "param_defs.inc" + +c/*@@ +c @routine Exact__decode_pars +c @date Fri Jun 7 19:47:46 CEST 2002 +c @author Jonathan Thornburg +c @desc +c Decode/copy parameters for this thorn into grid scalars, so +c we can share this with friends for the use of the Calc_Tmunu +c code in ../include/Scalar_CalcTmunu.inc in computing the +c stress-energy tensor. +c @enddesc +c @version $Header$ +c@@*/ + subroutine Exact__decode_pars(CCTK_ARGUMENTS) + implicit none + DECLARE_CCTK_ARGUMENTS + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c decode exact_model into the integer decoded_exact_model +c + +c Minkowski spacetime + if (CCTK_Equals(exact_model, "Minkowski") .ne. 0) then + decoded_exact_model = EXACT__Minkowski + elseif (CCTK_Equals(exact_model, "Minkowski/shift") .ne. 0) then + decoded_exact_model = EXACT__Minkowski_shift + elseif (CCTK_Equals(exact_model, "Minkowski/funny") .ne. 0) then + decoded_exact_model = EXACT__Minkowski_funny + elseif (CCTK_Equals(exact_model, "Minkowski/gauge wave") .ne. 0) then + decoded_exact_model = EXACT__Minkowski_gauge_wave + elseif (CCTK_Equals(exact_model, "Minkowski/shifted gauge wave") .ne. 0) then + decoded_exact_model = EXACT__Minkowski_shifted_gauge_wave + elseif (CCTK_Equals(exact_model, "Minkowski/conf wave") .ne. 0) then + decoded_exact_model = EXACT__Minkowski_conf_wave + +c black hole spacetimes + elseif (CCTK_Equals(exact_model, "Schwarzschild/EF") .ne. 0) then + decoded_exact_model = EXACT__Schwarzschild_EF + elseif (CCTK_Equals(exact_model, "Schwarzschild/PG") .ne. 0) then + decoded_exact_model = EXACT__Schwarzschild_PG + elseif (CCTK_Equals(exact_model, "Schwarzschild/BL") .ne. 0) then + decoded_exact_model = EXACT__Schwarzschild_BL + elseif (CCTK_Equals(exact_model, "Schwarzschild/Novikov") .ne. 0) then + decoded_exact_model = EXACT__Schwarzschild_Novikov + elseif (CCTK_Equals(exact_model, "Kerr/Boyer-Lindquist") .ne. 0) then + decoded_exact_model = EXACT__Kerr_BoyerLindquist + elseif (CCTK_Equals(exact_model, "Kerr/Kerr-Schild") .ne. 0) then + decoded_exact_model = EXACT__Kerr_KerrSchild + elseif (CCTK_Equals(exact_model, "Kerr/Kerr-Schild/spherical") .ne. 0) then + decoded_exact_model = EXACT__Kerr_KerrSchild_spherical + elseif (CCTK_Equals(exact_model, "Schwarzschild-Lemaitre") .ne. 0) then + decoded_exact_model = EXACT__Schwarzschild_Lemaitre + elseif (CCTK_Equals(exact_model, "multi-BH") .ne. 0) then + decoded_exact_model = EXACT__multi_BH + elseif (CCTK_Equals(exact_model, "Alvi") .ne. 0) then + decoded_exact_model = EXACT__Alvi + elseif (CCTK_Equals(exact_model, "Thorne-fakebinary") .ne. 0) then + decoded_exact_model = EXACT__Thorne_fakebinary + +c cosmological spacetimes + elseif (CCTK_Equals(exact_model, "Lemaitre") .ne. 0) then + decoded_exact_model = EXACT__Lemaitre +C this metric doesnt work and has been moved to ../archive/ +CC elseif (CCTK_Equals(exact_model, "Robertson-Walker") .ne. 0) then +CC decoded_exact_model = EXACT__Robertson_Walker + elseif (CCTK_Equals(exact_model, "de Sitter") .ne. 0) then + decoded_exact_model = EXACT__de_Sitter + elseif (CCTK_Equals(exact_model, "de Sitter+Lambda") .ne. 0) then + decoded_exact_model = EXACT__de_Sitter_Lambda + elseif (CCTK_Equals(exact_model, "anti-de Sitter+Lambda") .ne. 0) then + decoded_exact_model = EXACT__anti_de_Sitter_Lambda + elseif (CCTK_Equals(exact_model, "Bianchi I") .ne. 0) then + decoded_exact_model = EXACT__Bianchi_I + elseif (CCTK_Equals(exact_model, "Goedel") .ne. 0) then + decoded_exact_model = EXACT__Goedel + elseif (CCTK_Equals(exact_model, "Bertotti") .ne. 0) then + decoded_exact_model = EXACT__Bertotti + elseif (CCTK_Equals(exact_model, "Kasner-like") .ne. 0) then + decoded_exact_model = EXACT__Kasner_like + elseif (CCTK_Equals(exact_model, "Kasner-axisymmetric") .ne. 0) then + decoded_exact_model = EXACT__Kasner_axisymmetric + elseif (CCTK_Equals(exact_model, "Kasner-generalized") .ne. 0) then + decoded_exact_model = EXACT__Kasner_generalized + elseif (CCTK_Equals(exact_model, "Gowdy-wave") .ne. 0) then + decoded_exact_model = EXACT__Gowdy_wave + elseif (CCTK_Equals(exact_model, "Milne") .ne. 0) then + decoded_exact_model = EXACT__Milne + +c miscellaneous spacetimes + elseif (CCTK_Equals(exact_model, "boost-rotation symmetric") .ne. 0) then + decoded_exact_model = EXACT__boost_rotation_symmetric + elseif (CCTK_Equals(exact_model, "bowl") .ne. 0) then + decoded_exact_model = EXACT__bowl + elseif (CCTK_Equals(exact_model, "constant density star") .ne. 0) then + decoded_exact_model = EXACT__constant_density_star + else + call CCTK_WARN(0, "Unknown exact_model") + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for Schwarzschild-Lemaitre metric +c (Schwarzschiled black hole with cosmological constant) +c + Schwarzschild_Lemaitre___Lambda = Schwarzschild_Lemaitre__Lambda + Schwarzschild_Lemaitre___mass = Schwarzschild_Lemaitre__mass + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for Lemaitre-type spacetime +c + Lemaitre___kappa = Lemaitre__kappa + Lemaitre___Lambda = Lemaitre__Lambda + Lemaitre___epsilon0 = Lemaitre__epsilon0 + Lemaitre___R0 = Lemaitre__R0 + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +CCC +CCC this metric doesnt work and has been moved to ../archive/ +CCc +CCc parameters for Robertson-Walker spacetime +CCc +CC Robertson_Walker___R0 = Robertson_Walker__R0 +CC Robertson_Walker___rho = Robertson_Walker__rho +CC Robertson_Walker___k = Robertson_Walker__k +CC Robertson_Walker___pressure = Robertson_Walker__pressure +CC +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for de Sitter spacetime +c + de_Sitter___scale = de_Sitter__scale + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for de Sitter spacetime with cosmological constant +c + de_Sitter_Lambda___scale = de_Sitter_Lambda__scale + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for anti-de Sitter spacetime with cosmological constant +c + anti_de_Sitter_Lambda___scale = anti_de_Sitter_Lambda__scale + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for Bertotti spacetime +c + Bertotti___Lambda = Bertotti__Lambda + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for Kasner-like spacetime +c + Kasner_like___q = Kasner_like__q + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for generalized Kasner spacetime +c + Kasner_generalized___p1 = Kasner_generalized__p1 + Kasner_generalized___p2 = Kasner_generalized__p2 + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c parameters for constant density (Schwarzschild) star +c + constant_density_star___mass = constant_density_star__mass + constant_density_star___radius = constant_density_star__radius + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + return + end diff --git a/src/decode_pars.F77 b/src/decode_pars.F77 deleted file mode 100644 index d51bb4a..0000000 --- a/src/decode_pars.F77 +++ /dev/null @@ -1,214 +0,0 @@ -c/*@@ -c @file decode_pars.F -c @date Fri Jun 7 19:47:46 CEST 2002 -c @author Jonathan Thornburg -c @desc -c Decode/copy parameters for this thorn into grid scalars -c so we can share this with friends -c so the Calc_Tmunu code in ../include/Scalar_CalcTmunu.inc -c can use them in computing the stress-energy tensor -c -c Actually we only have to copy those parameters which are -c used by the Calc_Tmunu code. For simplicity we decode -c exact_model into the integer decoded_exact_model, then -c copy only the per-model parameters for those models which -c have stress-energy tensor code in ../include/Scalar_CalcTmunu.inc . -c -c @enddesc -c @version $Header$ -c@@*/ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - -#include "param_defs.inc" - -c/*@@ -c @routine Exact__decode_pars -c @date Fri Jun 7 19:47:46 CEST 2002 -c @author Jonathan Thornburg -c @desc -c Decode/copy parameters for this thorn into grid scalars, so -c we can share this with friends for the use of the Calc_Tmunu -c code in ../include/Scalar_CalcTmunu.inc in computing the -c stress-energy tensor. -c @enddesc -c @version $Header$ -c@@*/ - subroutine Exact__decode_pars(CCTK_ARGUMENTS) - implicit none - DECLARE_CCTK_ARGUMENTS - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c decode exact_model into the integer decoded_exact_model -c - -c Minkowski spacetime - if (CCTK_Equals(exact_model, "Minkowski") .ne. 0) then - decoded_exact_model = EXACT__Minkowski - elseif (CCTK_Equals(exact_model, "Minkowski/shift") .ne. 0) then - decoded_exact_model = EXACT__Minkowski_shift - elseif (CCTK_Equals(exact_model, "Minkowski/funny") .ne. 0) then - decoded_exact_model = EXACT__Minkowski_funny - elseif (CCTK_Equals(exact_model, "Minkowski/gauge wave") .ne. 0) then - decoded_exact_model = EXACT__Minkowski_gauge_wave - elseif (CCTK_Equals(exact_model, "Minkowski/shifted gauge wave") .ne. 0) then - decoded_exact_model = EXACT__Minkowski_shifted_gauge_wave - elseif (CCTK_Equals(exact_model, "Minkowski/conf wave") .ne. 0) then - decoded_exact_model = EXACT__Minkowski_conf_wave - -c black hole spacetimes - elseif (CCTK_Equals(exact_model, "Schwarzschild/EF") .ne. 0) then - decoded_exact_model = EXACT__Schwarzschild_EF - elseif (CCTK_Equals(exact_model, "Schwarzschild/PG") .ne. 0) then - decoded_exact_model = EXACT__Schwarzschild_PG - elseif (CCTK_Equals(exact_model, "Schwarzschild/BL") .ne. 0) then - decoded_exact_model = EXACT__Schwarzschild_BL - elseif (CCTK_Equals(exact_model, "Schwarzschild/Novikov") .ne. 0) then - decoded_exact_model = EXACT__Schwarzschild_Novikov - elseif (CCTK_Equals(exact_model, "Kerr/Boyer-Lindquist") .ne. 0) then - decoded_exact_model = EXACT__Kerr_BoyerLindquist - elseif (CCTK_Equals(exact_model, "Kerr/Kerr-Schild") .ne. 0) then - decoded_exact_model = EXACT__Kerr_KerrSchild - elseif (CCTK_Equals(exact_model, "Kerr/Kerr-Schild/spherical") .ne. 0) then - decoded_exact_model = EXACT__Kerr_KerrSchild_spherical - elseif (CCTK_Equals(exact_model, "Schwarzschild-Lemaitre") .ne. 0) then - decoded_exact_model = EXACT__Schwarzschild_Lemaitre - elseif (CCTK_Equals(exact_model, "multi-BH") .ne. 0) then - decoded_exact_model = EXACT__multi_BH - elseif (CCTK_Equals(exact_model, "Alvi") .ne. 0) then - decoded_exact_model = EXACT__Alvi - elseif (CCTK_Equals(exact_model, "Thorne-fakebinary") .ne. 0) then - decoded_exact_model = EXACT__Thorne_fakebinary - -c cosmological spacetimes - elseif (CCTK_Equals(exact_model, "Lemaitre") .ne. 0) then - decoded_exact_model = EXACT__Lemaitre -C this metric doesnt work and has been moved to ../archive/ -CC elseif (CCTK_Equals(exact_model, "Robertson-Walker") .ne. 0) then -CC decoded_exact_model = EXACT__Robertson_Walker - elseif (CCTK_Equals(exact_model, "de Sitter") .ne. 0) then - decoded_exact_model = EXACT__de_Sitter - elseif (CCTK_Equals(exact_model, "de Sitter+Lambda") .ne. 0) then - decoded_exact_model = EXACT__de_Sitter_Lambda - elseif (CCTK_Equals(exact_model, "anti-de Sitter+Lambda") .ne. 0) then - decoded_exact_model = EXACT__anti_de_Sitter_Lambda - elseif (CCTK_Equals(exact_model, "Bianchi I") .ne. 0) then - decoded_exact_model = EXACT__Bianchi_I - elseif (CCTK_Equals(exact_model, "Goedel") .ne. 0) then - decoded_exact_model = EXACT__Goedel - elseif (CCTK_Equals(exact_model, "Bertotti") .ne. 0) then - decoded_exact_model = EXACT__Bertotti - elseif (CCTK_Equals(exact_model, "Kasner-like") .ne. 0) then - decoded_exact_model = EXACT__Kasner_like - elseif (CCTK_Equals(exact_model, "Kasner-axisymmetric") .ne. 0) then - decoded_exact_model = EXACT__Kasner_axisymmetric - elseif (CCTK_Equals(exact_model, "Kasner-generalized") .ne. 0) then - decoded_exact_model = EXACT__Kasner_generalized - elseif (CCTK_Equals(exact_model, "Gowdy-wave") .ne. 0) then - decoded_exact_model = EXACT__Gowdy_wave - elseif (CCTK_Equals(exact_model, "Milne") .ne. 0) then - decoded_exact_model = EXACT__Milne - -c miscellaneous spacetimes - elseif (CCTK_Equals(exact_model, "boost-rotation symmetric") .ne. 0) then - decoded_exact_model = EXACT__boost_rotation_symmetric - elseif (CCTK_Equals(exact_model, "bowl") .ne. 0) then - decoded_exact_model = EXACT__bowl - elseif (CCTK_Equals(exact_model, "constant density star") .ne. 0) then - decoded_exact_model = EXACT__constant_density_star - else - call CCTK_WARN(0, "Unknown exact_model") - endif - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for Schwarzschild-Lemaitre metric -c (Schwarzschiled black hole with cosmological constant) -c - Schwarzschild_Lemaitre___Lambda = Schwarzschild_Lemaitre__Lambda - Schwarzschild_Lemaitre___mass = Schwarzschild_Lemaitre__mass - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for Lemaitre-type spacetime -c - Lemaitre___kappa = Lemaitre__kappa - Lemaitre___Lambda = Lemaitre__Lambda - Lemaitre___epsilon0 = Lemaitre__epsilon0 - Lemaitre___R0 = Lemaitre__R0 - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -CCC -CCC this metric doesnt work and has been moved to ../archive/ -CCc -CCc parameters for Robertson-Walker spacetime -CCc -CC Robertson_Walker___R0 = Robertson_Walker__R0 -CC Robertson_Walker___rho = Robertson_Walker__rho -CC Robertson_Walker___k = Robertson_Walker__k -CC Robertson_Walker___pressure = Robertson_Walker__pressure -CC -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for de Sitter spacetime -c - de_Sitter___scale = de_Sitter__scale - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for de Sitter spacetime with cosmological constant -c - de_Sitter_Lambda___scale = de_Sitter_Lambda__scale - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for anti-de Sitter spacetime with cosmological constant -c - anti_de_Sitter_Lambda___scale = anti_de_Sitter_Lambda__scale - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for Bertotti spacetime -c - Bertotti___Lambda = Bertotti__Lambda - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for Kasner-like spacetime -c - Kasner_like___q = Kasner_like__q - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for generalized Kasner spacetime -c - Kasner_generalized___p1 = Kasner_generalized__p1 - Kasner_generalized___p2 = Kasner_generalized__p2 - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c parameters for constant density (Schwarzschild) star -c - constant_density_star___mass = constant_density_star__mass - constant_density_star___radius = constant_density_star__radius - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - return - end diff --git a/src/gauge.F b/src/gauge.F new file mode 100644 index 0000000..93ceb6a --- /dev/null +++ b/src/gauge.F @@ -0,0 +1,187 @@ +C This routine sets the lapse and/or shift by calling a routine +C that does it pointwise. Note that it could be easily modified +C to set the Bona-Masso variables B_xx etc. +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + + subroutine Exact__gauge(CCTK_ARGUMENTS) + + implicit none + + DECLARE_CCTK_ARGUMENTS + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + + integer i,j,k + integer nx,ny,nz + logical set_lapse, set_dtlapse, set_shift, set_dtshift + + CCTK_REAL tt, xx, yy, zz + CCTK_REAL gxxtmp, gyytmp, gzztmp, + $ gxytmp, gyztmp, gxztmp, + $ hxxtmp, hyytmp, hzztmp, + $ hxytmp, hyztmp, hxztmp, + $ dxgxxtmp, dxgyytmp, dxgzztmp, + $ dxgxytmp, dxgyztmp, dxgxztmp, + $ dygxxtmp, dygyytmp, dygzztmp, + $ dygxytmp, dygyztmp, dygxztmp, + $ dzgxxtmp, dzgyytmp, dzgzztmp, + $ dzgxytmp, dzgyztmp, dzgxztmp, + $ alptmp, dtalptmp, axtmp, aytmp, aztmp, + $ betaxtmp, betaytmp, betaztmp, + $ dtbetaxtmp, dtbetaytmp, dtbetaztmp, + $ bxxtmp, bxytmp, bxztmp, + $ byxtmp, byytmp, byztmp, + $ bzxtmp, bzytmp, bzztmp + CCTK_REAL + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz + LOGICAL is_initial_slice, is_later_slice + +C are we on the initial slice or some later slice? +C n.b. the logical expressions later in this function involving +C these flags below would be *so* much nicer if Fortran +C grokked C-style conditional expressions... :) :) + is_initial_slice = cctk_iteration .eq. 0 + is_later_slice = cctk_iteration .ne. 0 + +C Grid parameters. + nx = cctk_lsh(1) + ny = cctk_lsh(2) + nz = cctk_lsh(3) + +C This code used to set t = time + dt/2 to get 2nd order accuracy, +C but this leads to the initial data being set at the wrong time. :( +C In the context of MoL, we want to set variables at the standard Cactus +C time (cctk_time), because MoL takes care of calling us at each MoL +C iteration, and updating the field variables appropriately. +C +C Alas, setting at cctk_time probably gives O(dt) errors for non-MoL +C evoutions where Exact is used to set stuff at each time step. +C Fixing this [unless we just declare all non-MoL stuff obselete :) ] +C probably requires cleaning up our (++messy) schedule.ccl , which +C is why this remains a bug for now... :( :( + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +C +C Set lapse and/or shift? +C + if ( is_initial_slice ) then + set_lapse = CCTK_Equals(initial_lapse, "exact").ne.0 + set_shift = CCTK_Equals(initial_shift, "exact").ne.0 + set_dtlapse = CCTK_Equals(initial_dtlapse, "exact").ne.0 + set_dtshift = CCTK_Equals(initial_dtshift, "exact").ne.0 + end if + if ( is_later_slice ) then + set_lapse = CCTK_Equals(lapse_evolution_method, "exact").ne.0 + set_shift = CCTK_Equals(shift_evolution_method, "exact").ne.0 + set_dtlapse = CCTK_Equals(dtlapse_evolution_method, "exact").ne.0 + set_dtshift = CCTK_Equals(dtshift_evolution_method, "exact").ne.0 + end if + + if ( set_lapse .or. set_shift .or. set_dtlapse .or. set_dtshift) then + +C$omp parallel do private ( +C$omp$ i, j, k, +C$omp$ tt, xx, yy, zz, +C$omp$ alptmp, dtalptmp, axtmp, aytmp, aztmp, +C$omp$ betaxtmp, betaytmp, betaztmp, +C$omp$ dtbetaxtmp, dtbetaytmp, dtbetaztmp, +C$omp$ bxxtmp, bxytmp, bxztmp, +C$omp$ byxtmp, byytmp, byztmp, +C$omp$ bzxtmp, bzytmp, bzztmp, +C$omp$ dxgxxtmp, dxgyytmp, dxgzztmp, +C$omp$ dxgxytmp, dxgyztmp, dxgxztmp, +C$omp$ dygxxtmp, dygyytmp, dygzztmp, +C$omp$ dygxytmp, dygyztmp, dygxztmp, +C$omp$ dzgxxtmp, dzgyytmp, dzgzztmp, +C$omp$ dzgxytmp, dzgyztmp, dzgxztmp, +C$omp$ exact_psi, +C$omp$ exact_psix, exact_psiy, exact_psiz, +C$omp$ exact_psixx, exact_psiyy, exact_psizz, +C$omp$ exact_psixy, exact_psiyz, exact_psixz) + do k=1,nz + do j=1,ny + do i=1,nx + + tt = cctk_time + xx = x(i,j,k) - cctk_time * shift_add_x + yy = y(i,j,k) - cctk_time * shift_add_y + zz = z(i,j,k) - cctk_time * shift_add_z + +C Initialize the psi of exact +C (also to tell the models about the conformal_state) + if (conformal_state .ne. 0) then + exact_psi = 1.0D0 + else + exact_psi = 0.0D0 + end if + exact_psix = 0.0D0 + exact_psiy = 0.0D0 + exact_psiz = 0.0D0 + exact_psixx = 0.0D0 + exact_psiyy = 0.0D0 + exact_psizz = 0.0D0 + exact_psixy = 0.0D0 + exact_psiyz = 0.0D0 + exact_psixz = 0.0D0 + + call Exact__Bona_Masso_data( + $ decoded_exact_model, + $ xx, yy, zz, tt, + $ gxxtmp, gyytmp, gzztmp, + $ gxytmp, gyztmp, gxztmp, + $ hxxtmp, hyytmp, hzztmp, + $ hxytmp, hyztmp, hxztmp, + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz, + $ dxgxxtmp, dxgyytmp, dxgzztmp, + $ dxgxytmp, dxgyztmp, dxgxztmp, + $ dygxxtmp, dygyytmp, dygzztmp, + $ dygxytmp, dygyztmp, dygxztmp, + $ dzgxxtmp, dzgyytmp, dzgzztmp, + $ dzgxytmp, dzgyztmp, dzgxztmp, + $ alptmp, dtalptmp, axtmp, aytmp, aztmp, + $ betaxtmp, betaytmp, betaztmp, + $ dtbetaxtmp, dtbetaytmp, dtbetaztmp, + $ bxxtmp, bxytmp, bxztmp, + $ byxtmp, byytmp, byztmp, + $ bzxtmp, bzytmp, bzztmp) + + if ( set_lapse ) then + alp(i,j,k) = alptmp + end if + if ( set_shift ) then + betax(i,j,k) = betaxtmp + shift_add_x + betay(i,j,k) = betaytmp + shift_add_y + betaz(i,j,k) = betaztmp + shift_add_z + end if + if ( set_dtlapse ) then + dtalp(i,j,k) = dtalptmp + end if + if ( set_dtshift ) then + dtbetax(i,j,k) = dtbetaxtmp + dtbetay(i,j,k) = dtbetaytmp + dtbetaz(i,j,k) = dtbetaztmp + end if + end do + end do + end do + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + else + call CCTK_WARN(1,'Exact__gauge has been called without doing anything') + end if + + return + end diff --git a/src/gauge.F77 b/src/gauge.F77 deleted file mode 100644 index 93ceb6a..0000000 --- a/src/gauge.F77 +++ /dev/null @@ -1,187 +0,0 @@ -C This routine sets the lapse and/or shift by calling a routine -C that does it pointwise. Note that it could be easily modified -C to set the Bona-Masso variables B_xx etc. -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - - subroutine Exact__gauge(CCTK_ARGUMENTS) - - implicit none - - DECLARE_CCTK_ARGUMENTS - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - - integer i,j,k - integer nx,ny,nz - logical set_lapse, set_dtlapse, set_shift, set_dtshift - - CCTK_REAL tt, xx, yy, zz - CCTK_REAL gxxtmp, gyytmp, gzztmp, - $ gxytmp, gyztmp, gxztmp, - $ hxxtmp, hyytmp, hzztmp, - $ hxytmp, hyztmp, hxztmp, - $ dxgxxtmp, dxgyytmp, dxgzztmp, - $ dxgxytmp, dxgyztmp, dxgxztmp, - $ dygxxtmp, dygyytmp, dygzztmp, - $ dygxytmp, dygyztmp, dygxztmp, - $ dzgxxtmp, dzgyytmp, dzgzztmp, - $ dzgxytmp, dzgyztmp, dzgxztmp, - $ alptmp, dtalptmp, axtmp, aytmp, aztmp, - $ betaxtmp, betaytmp, betaztmp, - $ dtbetaxtmp, dtbetaytmp, dtbetaztmp, - $ bxxtmp, bxytmp, bxztmp, - $ byxtmp, byytmp, byztmp, - $ bzxtmp, bzytmp, bzztmp - CCTK_REAL - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz - LOGICAL is_initial_slice, is_later_slice - -C are we on the initial slice or some later slice? -C n.b. the logical expressions later in this function involving -C these flags below would be *so* much nicer if Fortran -C grokked C-style conditional expressions... :) :) - is_initial_slice = cctk_iteration .eq. 0 - is_later_slice = cctk_iteration .ne. 0 - -C Grid parameters. - nx = cctk_lsh(1) - ny = cctk_lsh(2) - nz = cctk_lsh(3) - -C This code used to set t = time + dt/2 to get 2nd order accuracy, -C but this leads to the initial data being set at the wrong time. :( -C In the context of MoL, we want to set variables at the standard Cactus -C time (cctk_time), because MoL takes care of calling us at each MoL -C iteration, and updating the field variables appropriately. -C -C Alas, setting at cctk_time probably gives O(dt) errors for non-MoL -C evoutions where Exact is used to set stuff at each time step. -C Fixing this [unless we just declare all non-MoL stuff obselete :) ] -C probably requires cleaning up our (++messy) schedule.ccl , which -C is why this remains a bug for now... :( :( - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -C -C Set lapse and/or shift? -C - if ( is_initial_slice ) then - set_lapse = CCTK_Equals(initial_lapse, "exact").ne.0 - set_shift = CCTK_Equals(initial_shift, "exact").ne.0 - set_dtlapse = CCTK_Equals(initial_dtlapse, "exact").ne.0 - set_dtshift = CCTK_Equals(initial_dtshift, "exact").ne.0 - end if - if ( is_later_slice ) then - set_lapse = CCTK_Equals(lapse_evolution_method, "exact").ne.0 - set_shift = CCTK_Equals(shift_evolution_method, "exact").ne.0 - set_dtlapse = CCTK_Equals(dtlapse_evolution_method, "exact").ne.0 - set_dtshift = CCTK_Equals(dtshift_evolution_method, "exact").ne.0 - end if - - if ( set_lapse .or. set_shift .or. set_dtlapse .or. set_dtshift) then - -C$omp parallel do private ( -C$omp$ i, j, k, -C$omp$ tt, xx, yy, zz, -C$omp$ alptmp, dtalptmp, axtmp, aytmp, aztmp, -C$omp$ betaxtmp, betaytmp, betaztmp, -C$omp$ dtbetaxtmp, dtbetaytmp, dtbetaztmp, -C$omp$ bxxtmp, bxytmp, bxztmp, -C$omp$ byxtmp, byytmp, byztmp, -C$omp$ bzxtmp, bzytmp, bzztmp, -C$omp$ dxgxxtmp, dxgyytmp, dxgzztmp, -C$omp$ dxgxytmp, dxgyztmp, dxgxztmp, -C$omp$ dygxxtmp, dygyytmp, dygzztmp, -C$omp$ dygxytmp, dygyztmp, dygxztmp, -C$omp$ dzgxxtmp, dzgyytmp, dzgzztmp, -C$omp$ dzgxytmp, dzgyztmp, dzgxztmp, -C$omp$ exact_psi, -C$omp$ exact_psix, exact_psiy, exact_psiz, -C$omp$ exact_psixx, exact_psiyy, exact_psizz, -C$omp$ exact_psixy, exact_psiyz, exact_psixz) - do k=1,nz - do j=1,ny - do i=1,nx - - tt = cctk_time - xx = x(i,j,k) - cctk_time * shift_add_x - yy = y(i,j,k) - cctk_time * shift_add_y - zz = z(i,j,k) - cctk_time * shift_add_z - -C Initialize the psi of exact -C (also to tell the models about the conformal_state) - if (conformal_state .ne. 0) then - exact_psi = 1.0D0 - else - exact_psi = 0.0D0 - end if - exact_psix = 0.0D0 - exact_psiy = 0.0D0 - exact_psiz = 0.0D0 - exact_psixx = 0.0D0 - exact_psiyy = 0.0D0 - exact_psizz = 0.0D0 - exact_psixy = 0.0D0 - exact_psiyz = 0.0D0 - exact_psixz = 0.0D0 - - call Exact__Bona_Masso_data( - $ decoded_exact_model, - $ xx, yy, zz, tt, - $ gxxtmp, gyytmp, gzztmp, - $ gxytmp, gyztmp, gxztmp, - $ hxxtmp, hyytmp, hzztmp, - $ hxytmp, hyztmp, hxztmp, - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz, - $ dxgxxtmp, dxgyytmp, dxgzztmp, - $ dxgxytmp, dxgyztmp, dxgxztmp, - $ dygxxtmp, dygyytmp, dygzztmp, - $ dygxytmp, dygyztmp, dygxztmp, - $ dzgxxtmp, dzgyytmp, dzgzztmp, - $ dzgxytmp, dzgyztmp, dzgxztmp, - $ alptmp, dtalptmp, axtmp, aytmp, aztmp, - $ betaxtmp, betaytmp, betaztmp, - $ dtbetaxtmp, dtbetaytmp, dtbetaztmp, - $ bxxtmp, bxytmp, bxztmp, - $ byxtmp, byytmp, byztmp, - $ bzxtmp, bzytmp, bzztmp) - - if ( set_lapse ) then - alp(i,j,k) = alptmp - end if - if ( set_shift ) then - betax(i,j,k) = betaxtmp + shift_add_x - betay(i,j,k) = betaytmp + shift_add_y - betaz(i,j,k) = betaztmp + shift_add_z - end if - if ( set_dtlapse ) then - dtalp(i,j,k) = dtalptmp - end if - if ( set_dtshift ) then - dtbetax(i,j,k) = dtbetaxtmp - dtbetay(i,j,k) = dtbetaytmp - dtbetaz(i,j,k) = dtbetaztmp - end if - end do - end do - end do - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - else - call CCTK_WARN(1,'Exact__gauge has been called without doing anything') - end if - - return - end diff --git a/src/initialize.F b/src/initialize.F new file mode 100644 index 0000000..a6bc967 --- /dev/null +++ b/src/initialize.F @@ -0,0 +1,161 @@ +C Wrapper for boostrotdata. Calls it and vectorini. +C Sets Cauchy data, lapse and shift, and what else is needed +C in the Bona-Masso formalism, at an initial time. +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + + subroutine Exact__initialize(CCTK_ARGUMENTS) + + implicit none + + DECLARE_CCTK_ARGUMENTS + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + + integer i,j,k + integer nx,ny,nz + + CCTK_REAL tt, xx, yy, zz + CCTK_REAL alpjunk, dtalpjunk, axjunk, ayjunk, azjunk, + $ betaxjunk, betayjunk, betazjunk, + $ dtbetaxjunk, dtbetayjunk, dtbetazjunk, + $ bxxjunk, bxyjunk, bxzjunk, + $ byxjunk, byyjunk, byzjunk, + $ bzxjunk, bzyjunk, bzzjunk + CCTK_REAL + $ dxgxxjunk, dxgyyjunk, dxgzzjunk, + $ dxgxyjunk, dxgyzjunk, dxgxzjunk, + $ dygxxjunk, dygyyjunk, dygzzjunk, + $ dygxyjunk, dygyzjunk, dygxzjunk, + $ dzgxxjunk, dzgyyjunk, dzgzzjunk, + $ dzgxyjunk, dzgyzjunk, dzgxzjunk + CCTK_REAL + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz + + call CCTK_INFO('setting exact data on slice') + +C Set conformal state + if (CCTK_EQUALS(metric_type, "static conformal")) then + conformal_state=1 + if (CCTK_EQUALS(conformal_storage,"factor+derivs")) then + conformal_state = 2 + else if + $ (CCTK_EQUALS(conformal_storage, "factor+derivs+2nd derivs")) + $ then + conformal_state = 3 + end if + end if + +C Note I assume time has been initialized to physical time. +C Set data pointwise. + + nx = cctk_lsh(1) + ny = cctk_lsh(2) + nz = cctk_lsh(3) + +C$omp parallel do private( +C$omp$ i, j, k, +C$omp$ tt, xx, yy, zz, +C$omp$ alpjunk, dtalpjunk, axjunk, ayjunk, azjunk, +C$omp$ betaxjunk, betayjunk, betazjunk, +C$omp$ dtbetaxjunk, dtbetayjunk, dtbetazjunk, +C$omp$ bxxjunk, bxyjunk, bxzjunk, +C$omp$ byxjunk, byyjunk, byzjunk, +C$omp$ bzxjunk, bzyjunk, bzzjunk, +C$omp$ dxgxxjunk, dxgyyjunk, dxgzzjunk, +C$omp$ dxgxyjunk, dxgyzjunk, dxgxzjunk, +C$omp$ dygxxjunk, dygyyjunk, dygzzjunk, +C$omp$ dygxyjunk, dygyzjunk, dygxzjunk, +C$omp$ dzgxxjunk, dzgyyjunk, dzgzzjunk, +C$omp$ dzgxyjunk, dzgyzjunk, dzgxzjunk, +C$omp$ exact_psi, +C$omp$ exact_psix, exact_psiy, exact_psiz, +C$omp$ exact_psixx, exact_psiyy, exact_psizz, +C$omp$ exact_psixy, exact_psiyz, exact_psixz) + do k=1,nz + do j=1,ny + do i=1,nx + + tt = cctk_time + xx = x(i,j,k) - cctk_time * shift_add_x + yy = y(i,j,k) - cctk_time * shift_add_y + zz = z(i,j,k) - cctk_time * shift_add_z + +C Initialize the psi of exact +C (also to tell the models about the conformal_state) + if (conformal_state .ne. 0) then + exact_psi = 1.0D0 + else + exact_psi = 0.0D0 + end if + exact_psix = 0.0D0 + exact_psiy = 0.0D0 + exact_psiz = 0.0D0 + exact_psixx = 0.0D0 + exact_psiyy = 0.0D0 + exact_psizz = 0.0D0 + exact_psixy = 0.0D0 + exact_psiyz = 0.0D0 + exact_psixz = 0.0D0 + + call Exact__Bona_Masso_data( + $ decoded_exact_model, + $ xx, yy, zz, tt, + $ gxx(i,j,k), gyy(i,j,k), gzz(i,j,k), + $ gxy(i,j,k), gyz(i,j,k), gxz(i,j,k), + $ kxx(i,j,k), kyy(i,j,k), kzz(i,j,k), + $ kxy(i,j,k), kyz(i,j,k), kxz(i,j,k), + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz, + $ dxgxxjunk, dxgyyjunk, dxgzzjunk, + $ dxgxyjunk, dxgyzjunk, dxgxzjunk, + $ dygxxjunk, dygyyjunk, dygzzjunk, + $ dygxyjunk, dygyzjunk, dygxzjunk, + $ dzgxxjunk, dzgyyjunk, dzgzzjunk, + $ dzgxyjunk, dzgyzjunk, dzgxzjunk, + $ alpjunk, dtalpjunk, axjunk, ayjunk, azjunk, + $ betaxjunk, betayjunk, betazjunk, + $ dtbetaxjunk, dtbetayjunk, dtbetazjunk, + $ bxxjunk, bxyjunk, bxzjunk, + $ byxjunk, byyjunk, byzjunk, + $ bzxjunk, bzyjunk, bzzjunk) + +C Save the conformal factor if wanted + if (conformal_state .ne. 0) then + psi(i,j,k) = exact_psi + if (conformal_state .gt. 1) then + psix(i,j,k) = exact_psix + psiy(i,j,k) = exact_psiy + psiz(i,j,k) = exact_psiz + if (conformal_state .gt. 2) then + psixx(i,j,k) = exact_psixx + psiyy(i,j,k) = exact_psiyy + psizz(i,j,k) = exact_psizz + psixy(i,j,k) = exact_psixy + psiyz(i,j,k) = exact_psiyz + psixz(i,j,k) = exact_psixz + end if + end if + end if + + end do + end do + end do + +C Tell the code there is no need to treat the conformal factor +C as a separate field. That is, we have set the physical metric here. +c Commented out in einstein revamp, now Exact does not inherit anything +c about the conformal factor +c Now it does again (see above, knarf) + + return + end diff --git a/src/initialize.F77 b/src/initialize.F77 deleted file mode 100644 index a6bc967..0000000 --- a/src/initialize.F77 +++ /dev/null @@ -1,161 +0,0 @@ -C Wrapper for boostrotdata. Calls it and vectorini. -C Sets Cauchy data, lapse and shift, and what else is needed -C in the Bona-Masso formalism, at an initial time. -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - - subroutine Exact__initialize(CCTK_ARGUMENTS) - - implicit none - - DECLARE_CCTK_ARGUMENTS - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - - integer i,j,k - integer nx,ny,nz - - CCTK_REAL tt, xx, yy, zz - CCTK_REAL alpjunk, dtalpjunk, axjunk, ayjunk, azjunk, - $ betaxjunk, betayjunk, betazjunk, - $ dtbetaxjunk, dtbetayjunk, dtbetazjunk, - $ bxxjunk, bxyjunk, bxzjunk, - $ byxjunk, byyjunk, byzjunk, - $ bzxjunk, bzyjunk, bzzjunk - CCTK_REAL - $ dxgxxjunk, dxgyyjunk, dxgzzjunk, - $ dxgxyjunk, dxgyzjunk, dxgxzjunk, - $ dygxxjunk, dygyyjunk, dygzzjunk, - $ dygxyjunk, dygyzjunk, dygxzjunk, - $ dzgxxjunk, dzgyyjunk, dzgzzjunk, - $ dzgxyjunk, dzgyzjunk, dzgxzjunk - CCTK_REAL - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz - - call CCTK_INFO('setting exact data on slice') - -C Set conformal state - if (CCTK_EQUALS(metric_type, "static conformal")) then - conformal_state=1 - if (CCTK_EQUALS(conformal_storage,"factor+derivs")) then - conformal_state = 2 - else if - $ (CCTK_EQUALS(conformal_storage, "factor+derivs+2nd derivs")) - $ then - conformal_state = 3 - end if - end if - -C Note I assume time has been initialized to physical time. -C Set data pointwise. - - nx = cctk_lsh(1) - ny = cctk_lsh(2) - nz = cctk_lsh(3) - -C$omp parallel do private( -C$omp$ i, j, k, -C$omp$ tt, xx, yy, zz, -C$omp$ alpjunk, dtalpjunk, axjunk, ayjunk, azjunk, -C$omp$ betaxjunk, betayjunk, betazjunk, -C$omp$ dtbetaxjunk, dtbetayjunk, dtbetazjunk, -C$omp$ bxxjunk, bxyjunk, bxzjunk, -C$omp$ byxjunk, byyjunk, byzjunk, -C$omp$ bzxjunk, bzyjunk, bzzjunk, -C$omp$ dxgxxjunk, dxgyyjunk, dxgzzjunk, -C$omp$ dxgxyjunk, dxgyzjunk, dxgxzjunk, -C$omp$ dygxxjunk, dygyyjunk, dygzzjunk, -C$omp$ dygxyjunk, dygyzjunk, dygxzjunk, -C$omp$ dzgxxjunk, dzgyyjunk, dzgzzjunk, -C$omp$ dzgxyjunk, dzgyzjunk, dzgxzjunk, -C$omp$ exact_psi, -C$omp$ exact_psix, exact_psiy, exact_psiz, -C$omp$ exact_psixx, exact_psiyy, exact_psizz, -C$omp$ exact_psixy, exact_psiyz, exact_psixz) - do k=1,nz - do j=1,ny - do i=1,nx - - tt = cctk_time - xx = x(i,j,k) - cctk_time * shift_add_x - yy = y(i,j,k) - cctk_time * shift_add_y - zz = z(i,j,k) - cctk_time * shift_add_z - -C Initialize the psi of exact -C (also to tell the models about the conformal_state) - if (conformal_state .ne. 0) then - exact_psi = 1.0D0 - else - exact_psi = 0.0D0 - end if - exact_psix = 0.0D0 - exact_psiy = 0.0D0 - exact_psiz = 0.0D0 - exact_psixx = 0.0D0 - exact_psiyy = 0.0D0 - exact_psizz = 0.0D0 - exact_psixy = 0.0D0 - exact_psiyz = 0.0D0 - exact_psixz = 0.0D0 - - call Exact__Bona_Masso_data( - $ decoded_exact_model, - $ xx, yy, zz, tt, - $ gxx(i,j,k), gyy(i,j,k), gzz(i,j,k), - $ gxy(i,j,k), gyz(i,j,k), gxz(i,j,k), - $ kxx(i,j,k), kyy(i,j,k), kzz(i,j,k), - $ kxy(i,j,k), kyz(i,j,k), kxz(i,j,k), - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz, - $ dxgxxjunk, dxgyyjunk, dxgzzjunk, - $ dxgxyjunk, dxgyzjunk, dxgxzjunk, - $ dygxxjunk, dygyyjunk, dygzzjunk, - $ dygxyjunk, dygyzjunk, dygxzjunk, - $ dzgxxjunk, dzgyyjunk, dzgzzjunk, - $ dzgxyjunk, dzgyzjunk, dzgxzjunk, - $ alpjunk, dtalpjunk, axjunk, ayjunk, azjunk, - $ betaxjunk, betayjunk, betazjunk, - $ dtbetaxjunk, dtbetayjunk, dtbetazjunk, - $ bxxjunk, bxyjunk, bxzjunk, - $ byxjunk, byyjunk, byzjunk, - $ bzxjunk, bzyjunk, bzzjunk) - -C Save the conformal factor if wanted - if (conformal_state .ne. 0) then - psi(i,j,k) = exact_psi - if (conformal_state .gt. 1) then - psix(i,j,k) = exact_psix - psiy(i,j,k) = exact_psiy - psiz(i,j,k) = exact_psiz - if (conformal_state .gt. 2) then - psixx(i,j,k) = exact_psixx - psiyy(i,j,k) = exact_psiyy - psizz(i,j,k) = exact_psizz - psixy(i,j,k) = exact_psixy - psiyz(i,j,k) = exact_psiyz - psixz(i,j,k) = exact_psixz - end if - end if - end if - - end do - end do - end do - -C Tell the code there is no need to treat the conformal factor -C as a separate field. That is, we have set the physical metric here. -c Commented out in einstein revamp, now Exact does not inherit anything -c about the conformal factor -c Now it does again (see above, knarf) - - return - end diff --git a/src/make.code.defn b/src/make.code.defn index 7e41e8d..7fe7c97 100644 --- a/src/make.code.defn +++ b/src/make.code.defn @@ -4,22 +4,22 @@ # Source files in this directory SRCS = ParamCheck.c \ Startup.c \ - decode_pars.F77 \ - initialize.F77 \ + decode_pars.F \ + initialize.F \ \ slice_initialize.F \ slice_evolve.F \ slice_data.F \ \ - gauge.F77 \ - Bona_Masso_data.F77 \ + gauge.F \ + Bona_Masso_data.F \ \ - boost.F77 \ - metric.F77 \ + boost.F \ + metric.F \ \ - boundary.F77 \ - blended_boundary.F77 \ - xyz_blended_boundary.F77 \ + boundary.F \ + blended_boundary.F \ + xyz_blended_boundary.F \ linear_extrap_one_bndry.F # Subdirectories containing source files to be compiled diff --git a/src/metric.F b/src/metric.F new file mode 100644 index 0000000..f28c948 --- /dev/null +++ b/src/metric.F @@ -0,0 +1,362 @@ +c This subroutine calculates the 4-metric and its inverse at an event, +c for a given model, by decoding decoded_exact_model and calling the +c appropriate subroutine for that model. +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + +#include "param_defs.inc" + + subroutine Exact__metric_for_model( + $ decoded_exact_model, + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + implicit none + DECLARE_CCTK_FUNCTIONS + +c arguments + CCTK_INT decoded_exact_model + CCTK_REAL x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz + CCTK_REAL psi + LOGICAL Tmunu_flag + +c local variables + character*100 warn_buffer + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c Minkowski spacetime +c + + if (decoded_exact_model .eq. EXACT__Minkowski) then + call Exact__Minkowski( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Minkowski_shift) then + call Exact__Minkowski_shift( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Minkowski_funny) then + call Exact__Minkowski_funny( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Minkowski_gauge_wave) then + call Exact__Minkowski_gauge_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Minkowski_shifted_gauge_wave) then + call Exact__Minkowski_shifted_gauge_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Minkowski_conf_wave) then + call Exact__Minkowski_conf_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c black hole spacetimes +c + + elseif (decoded_exact_model .eq. EXACT__Schwarzschild_EF) then + call Exact__Schwarzschild_EF( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Schwarzschild_PG) then + call Exact__Schwarzschild_PG( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Schwarzschild_BL) then + call Exact__Schwarzschild_BL( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Schwarzschild_Novikov) then + call Exact__Schwarzschild_Novikov(x,y,z,t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Kerr_BoyerLindquist) then + call Exact__Kerr_BoyerLindquist( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Kerr_KerrSchild) then + call Exact__Kerr_KerrSchild( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Kerr_KerrSchild_spherical) then + call Exact__Kerr_KerrSchild_spherical( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Schwarzschild_Lemaitre) then + call Exact__Schwarzschild_Lemaitre( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__multi_BH) then + call Exact__multi_BH( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + +c +c not fully implemented yet -- see Nina Jansen for details +c +c elseif (decoded_exact_model .eq. EXACT__Alvi) then +c call Exact__Alvi( +c $ x, y, z, t, +c $ gdtt, gdtx, gdty, gdtz, +c $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, +c $ gutt, gutx, guty, gutz, +c $ guxx, guyy, guzz, guxy, guyz, guxz, +c $ psi, Tmunu_flag) +c + + elseif (decoded_exact_model .eq. EXACT__Thorne_fakebinary) then + call Exact__Thorne_fakebinary( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c cosmological spacetimes +c + + elseif (decoded_exact_model .eq. EXACT__Lemaitre) then + call Exact__Lemaitre( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__de_Sitter) then + call Exact__de_Sitter( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__de_Sitter_Lambda) then + call Exact__de_Sitter_Lambda( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__anti_de_Sitter_Lambda) then + call Exact__anti_de_Sitter_Lambda( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Bianchi_I) then + call Exact__Bianchi_I( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Goedel) then + call Exact__Goedel( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Bertotti) then + call Exact__Bertotti( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Kasner_like) then + call Exact__Kasner_like( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Kasner_axisymmetric) then + call Exact__Kasner_axisymmetric( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Kasner_generalized) then + call Exact__Kasner_generalized( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Gowdy_wave) then + call Exact__Gowdy_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__Milne) then + call Exact__Milne( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c +c miscellaneous spacetimes +c + + elseif (decoded_exact_model .eq. EXACT__boost_rotation_symmetric) then + call Exact__boost_rotation_symmetric( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__bowl) then + call Exact__bowl( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + elseif (decoded_exact_model .eq. EXACT__constant_density_star) then + call Exact__constant_density_star( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + else + write (warn_buffer, '(a,i8)') + $ 'Unknown decoded_exact_model = ', decoded_exact_model + call CCTK_WARN(0, warn_buffer) + endif + + return + end diff --git a/src/metric.F77 b/src/metric.F77 deleted file mode 100644 index f28c948..0000000 --- a/src/metric.F77 +++ /dev/null @@ -1,362 +0,0 @@ -c This subroutine calculates the 4-metric and its inverse at an event, -c for a given model, by decoding decoded_exact_model and calling the -c appropriate subroutine for that model. -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - -#include "param_defs.inc" - - subroutine Exact__metric_for_model( - $ decoded_exact_model, - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - implicit none - DECLARE_CCTK_FUNCTIONS - -c arguments - CCTK_INT decoded_exact_model - CCTK_REAL x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - character*100 warn_buffer - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c Minkowski spacetime -c - - if (decoded_exact_model .eq. EXACT__Minkowski) then - call Exact__Minkowski( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Minkowski_shift) then - call Exact__Minkowski_shift( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Minkowski_funny) then - call Exact__Minkowski_funny( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Minkowski_gauge_wave) then - call Exact__Minkowski_gauge_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Minkowski_shifted_gauge_wave) then - call Exact__Minkowski_shifted_gauge_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Minkowski_conf_wave) then - call Exact__Minkowski_conf_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c black hole spacetimes -c - - elseif (decoded_exact_model .eq. EXACT__Schwarzschild_EF) then - call Exact__Schwarzschild_EF( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Schwarzschild_PG) then - call Exact__Schwarzschild_PG( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Schwarzschild_BL) then - call Exact__Schwarzschild_BL( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Schwarzschild_Novikov) then - call Exact__Schwarzschild_Novikov(x,y,z,t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Kerr_BoyerLindquist) then - call Exact__Kerr_BoyerLindquist( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Kerr_KerrSchild) then - call Exact__Kerr_KerrSchild( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Kerr_KerrSchild_spherical) then - call Exact__Kerr_KerrSchild_spherical( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Schwarzschild_Lemaitre) then - call Exact__Schwarzschild_Lemaitre( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__multi_BH) then - call Exact__multi_BH( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - -c -c not fully implemented yet -- see Nina Jansen for details -c -c elseif (decoded_exact_model .eq. EXACT__Alvi) then -c call Exact__Alvi( -c $ x, y, z, t, -c $ gdtt, gdtx, gdty, gdtz, -c $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, -c $ gutt, gutx, guty, gutz, -c $ guxx, guyy, guzz, guxy, guyz, guxz, -c $ psi, Tmunu_flag) -c - - elseif (decoded_exact_model .eq. EXACT__Thorne_fakebinary) then - call Exact__Thorne_fakebinary( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c cosmological spacetimes -c - - elseif (decoded_exact_model .eq. EXACT__Lemaitre) then - call Exact__Lemaitre( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__de_Sitter) then - call Exact__de_Sitter( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__de_Sitter_Lambda) then - call Exact__de_Sitter_Lambda( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__anti_de_Sitter_Lambda) then - call Exact__anti_de_Sitter_Lambda( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Bianchi_I) then - call Exact__Bianchi_I( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Goedel) then - call Exact__Goedel( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Bertotti) then - call Exact__Bertotti( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Kasner_like) then - call Exact__Kasner_like( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Kasner_axisymmetric) then - call Exact__Kasner_axisymmetric( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Kasner_generalized) then - call Exact__Kasner_generalized( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Gowdy_wave) then - call Exact__Gowdy_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__Milne) then - call Exact__Milne( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -c -c miscellaneous spacetimes -c - - elseif (decoded_exact_model .eq. EXACT__boost_rotation_symmetric) then - call Exact__boost_rotation_symmetric( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__bowl) then - call Exact__bowl( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - elseif (decoded_exact_model .eq. EXACT__constant_density_star) then - call Exact__constant_density_star( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - else - write (warn_buffer, '(a,i8)') - $ 'Unknown decoded_exact_model = ', decoded_exact_model - call CCTK_WARN(0, warn_buffer) - endif - - return - end diff --git a/src/metrics/Alvi.F b/src/metrics/Alvi.F new file mode 100644 index 0000000..78bf84e --- /dev/null +++ b/src/metrics/Alvi.F @@ -0,0 +1,225 @@ +C The Alvi metric. Full description of this metric is given +C in gr-qc/9912113 . +C Author: Nina Jansen (jansen@aei-potsdam.mpg.de) +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Alvi( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_REAL psi + LOGICAL Tmunu_flag + +c locals + CCTK_REAL m1,m2,b + CCTK_REAL rin1,rin2,rout,x1,x2, r1, r2, r3, results(10) + +C this is a vacuum solution with no cosmological constant +C ==> it does not set the stress-energy tensor + Tmunu_flag = .false. + + m1 = Alvi__mass1 + m2 = Alvi__mass2 + b = Alvi__separation + + rin1 = dsqrt(m1*b) + rin2 = dsqrt(m2*b) + rout = b*dsqrt(b)/(2.0d0*dsqrt(m1+m2)) + + x1 = b + + x2 = -b + + r1 = dsqrt((x-x1)**2.0D0 + y**2.0D0 + z**2.0D0) + + + r2 = dsqrt((x-x2)**2.0D0 + y**2.0D0 + z**2.0D0) + + + r3 = dsqrt(x**2.0D0 + y**2.0D0 + z**2.0D0) + + if (r1 .le. rin1) then + + call Alvireg1(x,y,z,m1,m2,b,results) + + gdtt = results(1) + gdtx = results(2) + gdty = results(3) + gdtz = results(4) + gdxx = results(5) + gdyy = results(8) + gdzz = results(10) + gdxy = results(9) + gdyz = results(9) + gdzx = results(7) + + else if (r2 .le. rin2) then + + call Alvireg2(x,y,z,m1,m2,b,results) + + gdtt = results(1) + gdtx = results(2) + gdty = results(3) + gdtz = results(4) + gdxx = results(5) + gdyy = results(8) + gdzz = results(10) + gdxy = results(9) + gdyz = results(9) + gdzx = results(7) + + else if ((r3 .le. rout) .and. (r2 .gt. rin2) .and. (r1 .gt. rin1)) then + call Alvireg3(x,y,z,m1,m2,b,results) + + gdtt = results(1) + gdtx = results(2) + gdty = results(3) + gdtz = results(4) + gdxx = results(5) + gdyy = results(8) + gdzz = results(10) + gdxy = results(9) + gdyz = results(9) + gdzx = results(7) + + else if (r3 .gt. rout) then + call Alvireg4(x,y,z,m1,m2,b,results) + + gdtt = results(1) + gdtx = results(2) + gdty = results(3) + gdtz = results(4) + gdxx = results(5) + gdyy = results(8) + gdzz = results(10) + gdxy = results(9) + gdyz = results(9) + gdzx = results(7) + + else + + print *,'problem!' + + end if + + gutt = + $ (gdzx**2*gdyy - 2*gdxy*gdzx*gdyz + gdxy**2*gdzz + gdxx*(gdyz**2 + $ - gdyy*gdzz))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + + $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + + $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - + $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + + $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + + $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) + + gutx = + $ (-(gdtz*gdzx*gdyy) + gdtz*gdxy*gdyz + gdty*gdzx*gdyz - + $ gdtx*gdyz**2 - gdty*gdxy*gdzz + gdtx*gdyy*gdzz)/ + $ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + gdxx*gdyy) - + $ 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + gdtt*gdxx*gdyz**2 + + $ 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - gdty*gdxx*gdyz + + $ gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + gdtx**2*gdyy*gdzz - + $ gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + gdxx*gdzz) + + $ 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) + + + guty = + $ (-(gdtz*gdxy*gdzx) + gdty*gdzx**2 + gdtz*gdxx*gdyz - + $ gdtx*gdzx*gdyz - gdty*gdxx*gdzz + gdtx*gdxy*gdzz)/ + $ (-(gdtt*gdzx**2*gdyy) + gdtz**2*(gdxy**2 - gdxx*gdyy) + + $ 2*gdtt*gdxy*gdzx*gdyz + gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - + $ 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - gdty*gdxx*gdyz + + $ gdtx*gdxy*gdyz) - gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + + $ gdtt*gdxx*gdyy*gdzz + gdty**2*(gdzx**2 - gdxx*gdzz) + + $ gdty*(-2*gdtx*gdzx*gdyz + 2*gdtx*gdxy*gdzz)) + + + + + + gutz = + $ (-(gdty*gdxy*gdzx) + gdtx*gdzx*gdyy + gdtz*(gdxy**2 - gdxx*gdyy) + $ + gdty*gdxx*gdyz - gdtx*gdxy*gdyz)/ (-(gdtt*gdzx**2*gdyy) + + $ gdtz**2*(gdxy**2 - gdxx*gdyy) + 2*gdtt*gdxy*gdzx*gdyz + + $ gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - 2*gdtz*(gdty*gdxy*gdzx - + $ gdtx*gdzx*gdyy - gdty*gdxx*gdyz + gdtx*gdxy*gdyz) - + $ gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + gdtt*gdxx*gdyy*gdzz + + $ gdty**2*(gdzx**2 - gdxx*gdzz) + gdty*(-2*gdtx*gdzx*gdyz + + $ 2*gdtx*gdxy*gdzz)) + guxx = + $ (gdtz**2*gdyy - 2*gdty*gdtz*gdyz + gdty**2*gdzz + gdtt*(gdyz**2 + $ - gdyy*gdzz))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + + $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + + $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - + $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + + $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + + $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) + guyy = + $ (gdtz**2*gdxx - 2*gdtx*gdtz*gdzx + gdtx**2*gdzz + gdtt*(gdzx**2 + $ - gdxx*gdzz))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + + $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + + $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - + $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + + $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + + $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) + guzz = + $ (gdty**2*gdxx - 2*gdtx*gdty*gdxy + gdtx**2*gdyy + gdtt*(gdxy**2 + $ - gdxx*gdyy))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + + $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + + $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - + $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + + $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + + $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) + guxy = + $ (gdtz**2*gdxy + gdtt*gdzx*gdyz - gdtz*(gdty*gdzx + gdtx*gdyz) + + $ gdtx*gdty*gdzz - gdtt*gdxy*gdzz)/ (-(gdtt*gdzx**2*gdyy) + + $ gdtz**2*(gdxy**2 - gdxx*gdyy) + 2*gdtt*gdxy*gdzx*gdyz + + $ gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - 2*gdtz*(gdty*gdxy*gdzx - + $ gdtx*gdzx*gdyy - gdty*gdxx*gdyz + gdtx*gdxy*gdyz) - + $ gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + gdtt*gdxx*gdyy*gdzz + + $ gdty**2*(gdzx**2 - gdxx*gdzz) + gdty*(-2*gdtx*gdzx*gdyz + + $ 2*gdtx*gdxy*gdzz)) + guyz = + $ (-(gdty*gdtz*gdxx) + gdtx*gdtz*gdxy + gdtx*gdty*gdzx - + $ gdtt*gdxy*gdzx - gdtx**2*gdyz + gdtt*gdxx*gdyz)/ + $ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + gdxx*gdyy) - + $ 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + gdtt*gdxx*gdyz**2 + + $ 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - gdty*gdxx*gdyz + + $ gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + gdtx**2*gdyy*gdzz - + $ gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + gdxx*gdzz) + + $ 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) + guzx = + $ (gdty**2*gdzx + gdtx*gdtz*gdyy - gdtt*gdzx*gdyy + gdtt*gdxy*gdyz + $ - gdty*(gdtz*gdxy + gdtx*gdyz))/ (-(gdtt*gdzx**2*gdyy) + + $ gdtz**2*(gdxy**2 - gdxx*gdyy) + 2*gdtt*gdxy*gdzx*gdyz + + $ gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - 2*gdtz*(gdty*gdxy*gdzx - + $ gdtx*gdzx*gdyy - gdty*gdxx*gdyz + gdtx*gdxy*gdyz) - + $ gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + gdtt*gdxx*gdyy*gdzz + + $ gdty**2*(gdzx**2 - gdxx*gdzz) + gdty*(-2*gdtx*gdzx*gdyz + + $ 2*gdtx*gdxy*gdzz)) + + return + + end + + + + diff --git a/src/metrics/Alvi.F77 b/src/metrics/Alvi.F77 deleted file mode 100644 index 78bf84e..0000000 --- a/src/metrics/Alvi.F77 +++ /dev/null @@ -1,225 +0,0 @@ -C The Alvi metric. Full description of this metric is given -C in gr-qc/9912113 . -C Author: Nina Jansen (jansen@aei-potsdam.mpg.de) -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Alvi( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c locals - CCTK_REAL m1,m2,b - CCTK_REAL rin1,rin2,rout,x1,x2, r1, r2, r3, results(10) - -C this is a vacuum solution with no cosmological constant -C ==> it does not set the stress-energy tensor - Tmunu_flag = .false. - - m1 = Alvi__mass1 - m2 = Alvi__mass2 - b = Alvi__separation - - rin1 = dsqrt(m1*b) - rin2 = dsqrt(m2*b) - rout = b*dsqrt(b)/(2.0d0*dsqrt(m1+m2)) - - x1 = b - - x2 = -b - - r1 = dsqrt((x-x1)**2.0D0 + y**2.0D0 + z**2.0D0) - - - r2 = dsqrt((x-x2)**2.0D0 + y**2.0D0 + z**2.0D0) - - - r3 = dsqrt(x**2.0D0 + y**2.0D0 + z**2.0D0) - - if (r1 .le. rin1) then - - call Alvireg1(x,y,z,m1,m2,b,results) - - gdtt = results(1) - gdtx = results(2) - gdty = results(3) - gdtz = results(4) - gdxx = results(5) - gdyy = results(8) - gdzz = results(10) - gdxy = results(9) - gdyz = results(9) - gdzx = results(7) - - else if (r2 .le. rin2) then - - call Alvireg2(x,y,z,m1,m2,b,results) - - gdtt = results(1) - gdtx = results(2) - gdty = results(3) - gdtz = results(4) - gdxx = results(5) - gdyy = results(8) - gdzz = results(10) - gdxy = results(9) - gdyz = results(9) - gdzx = results(7) - - else if ((r3 .le. rout) .and. (r2 .gt. rin2) .and. (r1 .gt. rin1)) then - call Alvireg3(x,y,z,m1,m2,b,results) - - gdtt = results(1) - gdtx = results(2) - gdty = results(3) - gdtz = results(4) - gdxx = results(5) - gdyy = results(8) - gdzz = results(10) - gdxy = results(9) - gdyz = results(9) - gdzx = results(7) - - else if (r3 .gt. rout) then - call Alvireg4(x,y,z,m1,m2,b,results) - - gdtt = results(1) - gdtx = results(2) - gdty = results(3) - gdtz = results(4) - gdxx = results(5) - gdyy = results(8) - gdzz = results(10) - gdxy = results(9) - gdyz = results(9) - gdzx = results(7) - - else - - print *,'problem!' - - end if - - gutt = - $ (gdzx**2*gdyy - 2*gdxy*gdzx*gdyz + gdxy**2*gdzz + gdxx*(gdyz**2 - $ - gdyy*gdzz))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + - $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + - $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - - $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + - $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + - $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) - - gutx = - $ (-(gdtz*gdzx*gdyy) + gdtz*gdxy*gdyz + gdty*gdzx*gdyz - - $ gdtx*gdyz**2 - gdty*gdxy*gdzz + gdtx*gdyy*gdzz)/ - $ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + gdxx*gdyy) - - $ 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + gdtt*gdxx*gdyz**2 + - $ 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - gdty*gdxx*gdyz + - $ gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + gdtx**2*gdyy*gdzz - - $ gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + gdxx*gdzz) + - $ 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) - - - guty = - $ (-(gdtz*gdxy*gdzx) + gdty*gdzx**2 + gdtz*gdxx*gdyz - - $ gdtx*gdzx*gdyz - gdty*gdxx*gdzz + gdtx*gdxy*gdzz)/ - $ (-(gdtt*gdzx**2*gdyy) + gdtz**2*(gdxy**2 - gdxx*gdyy) + - $ 2*gdtt*gdxy*gdzx*gdyz + gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - - $ 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - gdty*gdxx*gdyz + - $ gdtx*gdxy*gdyz) - gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + - $ gdtt*gdxx*gdyy*gdzz + gdty**2*(gdzx**2 - gdxx*gdzz) + - $ gdty*(-2*gdtx*gdzx*gdyz + 2*gdtx*gdxy*gdzz)) - - - - - - gutz = - $ (-(gdty*gdxy*gdzx) + gdtx*gdzx*gdyy + gdtz*(gdxy**2 - gdxx*gdyy) - $ + gdty*gdxx*gdyz - gdtx*gdxy*gdyz)/ (-(gdtt*gdzx**2*gdyy) + - $ gdtz**2*(gdxy**2 - gdxx*gdyy) + 2*gdtt*gdxy*gdzx*gdyz + - $ gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - 2*gdtz*(gdty*gdxy*gdzx - - $ gdtx*gdzx*gdyy - gdty*gdxx*gdyz + gdtx*gdxy*gdyz) - - $ gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + gdtt*gdxx*gdyy*gdzz + - $ gdty**2*(gdzx**2 - gdxx*gdzz) + gdty*(-2*gdtx*gdzx*gdyz + - $ 2*gdtx*gdxy*gdzz)) - guxx = - $ (gdtz**2*gdyy - 2*gdty*gdtz*gdyz + gdty**2*gdzz + gdtt*(gdyz**2 - $ - gdyy*gdzz))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + - $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + - $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - - $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + - $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + - $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) - guyy = - $ (gdtz**2*gdxx - 2*gdtx*gdtz*gdzx + gdtx**2*gdzz + gdtt*(gdzx**2 - $ - gdxx*gdzz))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + - $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + - $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - - $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + - $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + - $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) - guzz = - $ (gdty**2*gdxx - 2*gdtx*gdty*gdxy + gdtx**2*gdyy + gdtt*(gdxy**2 - $ - gdxx*gdyy))/ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + - $ gdxx*gdyy) - 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + - $ gdtt*gdxx*gdyz**2 + 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - - $ gdty*gdxx*gdyz + gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + - $ gdtx**2*gdyy*gdzz - gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + - $ gdxx*gdzz) + 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) - guxy = - $ (gdtz**2*gdxy + gdtt*gdzx*gdyz - gdtz*(gdty*gdzx + gdtx*gdyz) + - $ gdtx*gdty*gdzz - gdtt*gdxy*gdzz)/ (-(gdtt*gdzx**2*gdyy) + - $ gdtz**2*(gdxy**2 - gdxx*gdyy) + 2*gdtt*gdxy*gdzx*gdyz + - $ gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - 2*gdtz*(gdty*gdxy*gdzx - - $ gdtx*gdzx*gdyy - gdty*gdxx*gdyz + gdtx*gdxy*gdyz) - - $ gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + gdtt*gdxx*gdyy*gdzz + - $ gdty**2*(gdzx**2 - gdxx*gdzz) + gdty*(-2*gdtx*gdzx*gdyz + - $ 2*gdtx*gdxy*gdzz)) - guyz = - $ (-(gdty*gdtz*gdxx) + gdtx*gdtz*gdxy + gdtx*gdty*gdzx - - $ gdtt*gdxy*gdzx - gdtx**2*gdyz + gdtt*gdxx*gdyz)/ - $ (gdtt*gdzx**2*gdyy + gdtz**2*(-gdxy**2 + gdxx*gdyy) - - $ 2*gdtt*gdxy*gdzx*gdyz - gdtx**2*gdyz**2 + gdtt*gdxx*gdyz**2 + - $ 2*gdtz*(gdty*gdxy*gdzx - gdtx*gdzx*gdyy - gdty*gdxx*gdyz + - $ gdtx*gdxy*gdyz) + gdtt*gdxy**2*gdzz + gdtx**2*gdyy*gdzz - - $ gdtt*gdxx*gdyy*gdzz + gdty**2*(-gdzx**2 + gdxx*gdzz) + - $ 2*gdtx*gdty*(gdzx*gdyz - gdxy*gdzz)) - guzx = - $ (gdty**2*gdzx + gdtx*gdtz*gdyy - gdtt*gdzx*gdyy + gdtt*gdxy*gdyz - $ - gdty*(gdtz*gdxy + gdtx*gdyz))/ (-(gdtt*gdzx**2*gdyy) + - $ gdtz**2*(gdxy**2 - gdxx*gdyy) + 2*gdtt*gdxy*gdzx*gdyz + - $ gdtx**2*gdyz**2 - gdtt*gdxx*gdyz**2 - 2*gdtz*(gdty*gdxy*gdzx - - $ gdtx*gdzx*gdyy - gdty*gdxx*gdyz + gdtx*gdxy*gdyz) - - $ gdtt*gdxy**2*gdzz - gdtx**2*gdyy*gdzz + gdtt*gdxx*gdyy*gdzz + - $ gdty**2*(gdzx**2 - gdxx*gdzz) + gdty*(-2*gdtx*gdzx*gdyz + - $ 2*gdtx*gdxy*gdzz)) - - return - - end - - - - diff --git a/src/metrics/Bertotti.F b/src/metrics/Bertotti.F new file mode 100644 index 0000000..fc05972 --- /dev/null +++ b/src/metrics/Bertotti.F @@ -0,0 +1,74 @@ +C Bertotti spacetime with cosmological constant +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Bertotti( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, z + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL baza + CCTK_REAL unu, doi + +C this model has a cosmological constant +C ==> it sets the stress-energy tensor in the "CalcTmunu" code + Tmunu_flag = .true. + + baza = Bertotti__Lambda + + unu=exp(2.0D0*sqrt(-baza)*x) + doi=exp(2.0D0*sqrt(-baza)*z) + + + gdtt = -unu + gdtx = 0.0D0 + gdty = 0.0D0 + gdtz = 0.0D0 + gdxx = 1.0D0 + gdyy = doi + gdzz = 1.0D0 + gdxy = 0.0D0 + gdyz = 0.0D0 + gdzx = 0.0D0 + + gutt = -1.0D0/unu + gutx = 0.0D0 + guty = 0.0D0 + gutz = 0.0D0 + guxx = 1.0D0 + guyy = 1.0D0/doi + guzz = 1.0D0 + guxy = 0.0D0 + guyz = 0.0D0 + guzx = 0.0D0 + + + return + end diff --git a/src/metrics/Bertotti.F77 b/src/metrics/Bertotti.F77 deleted file mode 100644 index 003a282..0000000 --- a/src/metrics/Bertotti.F77 +++ /dev/null @@ -1,72 +0,0 @@ -C Bertotti spacetime with cosmological constant -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Bertotti( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL baza - CCTK_REAL unu, doi - -C this model has a cosmological constant -C ==> it sets the stress-energy tensor in the "CalcTmunu" code - Tmunu_flag = .true. - - baza = Bertotti__Lambda - - unu=exp(2.0D0*sqrt(-baza)*x) - doi=exp(2.0D0*sqrt(-baza)*z) - - - gdtt = -unu - gdtx = 0.0D0 - gdty = 0.0D0 - gdtz = 0.0D0 - gdxx = 1.0D0 - gdyy = doi - gdzz = 1.0D0 - gdxy = 0.0D0 - gdyz = 0.0D0 - gdzx = 0.0D0 - - gutt = -1.0D0/unu - gutx = 0.0D0 - guty = 0.0D0 - gutz = 0.0D0 - guxx = 1.0D0 - guyy = 1.0D0/doi - guzz = 1.0D0 - guxy = 0.0D0 - guyz = 0.0D0 - guzx = 0.0D0 - - - return - end diff --git a/src/metrics/Bianchi_I.F b/src/metrics/Bianchi_I.F new file mode 100644 index 0000000..436666d --- /dev/null +++ b/src/metrics/Bianchi_I.F @@ -0,0 +1,74 @@ +C Bianchi-I spacetime !!!! Fake one... +C It is not a real Bianchi I spacetime, it just emulates +C one, taking the two BianchiI functions as harmonic ones... +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Bianchi_I( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, t + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL arad + CCTK_REAL bx, by + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + + arad = Bianchi_I__scale + + bx = arad*sin(x+t) + by = arad*cos(x+t) + + gdtt = - 1.d0 + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = bx**2 + gdyy = by**2 + gdzz = by**2 + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = - 1.d0 + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = bx**(-2) + guyy = by**(-2) + guzz = by**(-2) + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + return + end diff --git a/src/metrics/Bianchi_I.F77 b/src/metrics/Bianchi_I.F77 deleted file mode 100644 index b29713e..0000000 --- a/src/metrics/Bianchi_I.F77 +++ /dev/null @@ -1,71 +0,0 @@ -C Bianchi-I spacetime !!!! Fake one... -C It is not a real Bianchi I spacetime, it just emulates -C one, taking the two BianchiI functions as harmonic ones... -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Bianchi_I( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL arad - CCTK_REAL bx, by - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - - arad = Bianchi_I__scale - - bx = arad*sin(x+t) - by = arad*cos(x+t) - - gdtt = - 1.d0 - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = bx**2 - gdyy = by**2 - gdzz = by**2 - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = - 1.d0 - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = bx**(-2) - guyy = by**(-2) - guzz = by**(-2) - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - return - end diff --git a/src/metrics/Goedel.F b/src/metrics/Goedel.F new file mode 100644 index 0000000..e7dec99 --- /dev/null +++ b/src/metrics/Goedel.F @@ -0,0 +1,70 @@ +C Goedel spacetime !!!! +C See: S. Hawking, G.F.R. Ellis, The Large +C Scale Structure of space-time, Cambridge, 1973 +C +C Author : D. Vulcanov (Timsioara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Goedel( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL arad + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + + arad = Goedel__scale + + gdtt = -arad*arad + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = (1/2)*arad*arad*exp(x)*exp(x) + gdyy = -arad*arad + gdzz = arad*arad*exp(x) + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = arad*arad*exp(x) + + gutt = -1/(arad*arad) + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = -2/(arad*arad*exp(x)*exp(x)) + guyy = -1/(arad*arad) + guzz = -1/(arad*arad*exp(x)) + guxy = 0.d0 + guyz = 0.d0 + guzx = 2/(arad*arad*exp(x)) + + return + end diff --git a/src/metrics/Goedel.F77 b/src/metrics/Goedel.F77 deleted file mode 100644 index 5b662b2..0000000 --- a/src/metrics/Goedel.F77 +++ /dev/null @@ -1,67 +0,0 @@ -C Goedel spacetime !!!! -C See: S. Hawking, G.F.R. Ellis, The Large -C Scale Structure of space-time, Cambridge, 1973 -C -C Author : D. Vulcanov (Timsioara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Goedel( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL arad - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - - arad = Goedel__scale - - gdtt = -arad*arad - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = (1/2)*arad*arad*exp(x)*exp(x) - gdyy = -arad*arad - gdzz = arad*arad*exp(x) - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = arad*arad*exp(x) - - gutt = -1/(arad*arad) - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = -2/(arad*arad*exp(x)*exp(x)) - guyy = -1/(arad*arad) - guzz = -1/(arad*arad*exp(x)) - guxy = 0.d0 - guyz = 0.d0 - guzx = 2/(arad*arad*exp(x)) - - return - end diff --git a/src/metrics/Gowdy_wave.F b/src/metrics/Gowdy_wave.F new file mode 100644 index 0000000..580841c --- /dev/null +++ b/src/metrics/Gowdy_wave.F @@ -0,0 +1,246 @@ +C @@ +C @file Gowdy.F77 +C @date December 2002 +C @author Denis Pollney +C @desc +C Cosmological Gowdy metric for a polarized wave in an +C expanding universe. See +C "Stable 3-level leapfrog integration in numerical relativity" +C New, K, Watt, K, Misner, C and Centrella, J, PRD 58, 064022. +C @desc +C @version $Header$ +C @@ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Gowdy_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL z, t + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local static variables + logical firstcall + CCTK_REAL amp + CCTK_REAL PI, twoPI + CCTK_REAL Bessel_J0, Bessel_J1 + data firstcall /.true./ + save firstcall, amp, PI, twoPI, Bessel_J0, Bessel_J1 +c$omp threadprivate (firstcall, amp, PI, twoPI, Bessel_J0, Bessel_J1) + +c local variables + CCTK_REAL Bessel_J0_t, Bessel_J1_t + CCTK_REAL cosz, eP, lambda + CCTK_REAL d1, d2, d3, d4, d5, d6 + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + + if (firstcall) then + amp = Gowdy_wave__amplitude + PI = acos(-1.d0) + twoPI = 2.d0*PI + call jy01a(twoPI, Bessel_J0, d1, Bessel_J1, d2, d3, d4, d5, d6) + firstcall = .false. + end if + + if (t.eq.0.d0) then + call CCTK_WARN(0, "The Gowdy metric is singular for t=0. You may need to set cactus::cctk_initial_time > 0.") + end if + + call jy01a(twoPI*t, Bessel_J0_t, d1, Bessel_J1_t, d2, d3, d4, d5, d6) + + cosz = cos(twoPI*z) + eP = exp(Bessel_J0_t * cosz) + + lambda = amp * (-twoPI * t * Bessel_J0_t * Bessel_J1_t * cosz**2 + + + twoPI * PI * t**2 * (Bessel_J0_t**2 + Bessel_J1_t**2) + + - 0.5d0 * (twoPI**2 * (Bessel_J0**2 + Bessel_J1**2) + + - twoPI * Bessel_J0 * Bessel_J1)) +c +c lower metric components. +c + gdtt = -exp(0.5d0*lambda)/sqrt(t) + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = t * eP + gdyy = t / eP + gdzz = -gdtt + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + +c +c upper metric components. +c + gutt = 1.d0 / gdtt + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = 1.d0 / gdxx + guyy = 1.d0 / gdyy + guzz = 1.d0 / gdzz + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + return + end + +C @@ +C @routine Bessel.F77 +C @date December 2002 +C @author Denis Pollney +C @desc +C Compute bessel functions of 0th and 1st order. +C This routine was downloaded from: +C http://iris-lee3.ece.uiuc.edu/~jjin/routines/routines.html +C +C ======================================================= +C Purpose: Compute Bessel functions J0(x), J1(x), Y0(x), +C Y1(x), and their derivatives +C Input : x --- Argument of Jn(x) & Yn(x) ( x ? 0 ) +C Output: BJ0 --- J0(x) +C DJ0 --- dJ0(x) +C BJ1 --- J1(x) +C DJ1 --- dJ1(x) +C BY0 --- Y0(x) +C DY0 --- dY0(x) +C BY1 --- Y1(x) +C DY1 --- dY1(x) +C ======================================================= +C +C @desc +C @version $Header$ +C @@ + + SUBROUTINE JY01A(X,BJ0,DJ0,BJ1,DJ1,BY0,DY0,BY1,DY1) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION A(12),B(12),A1(12),B1(12) + PI=3.141592653589793D0 + RP2=0.63661977236758D0 + X2=X*X + IF (X.EQ.0.0D0) THEN + BJ0=1.0D0 + BJ1=0.0D0 + DJ0=0.0D0 + DJ1=0.5D0 + BY0=-1.0D+300 + BY1=-1.0D+300 + DY0=1.0D+300 + DY1=1.0D+300 + RETURN + ENDIF + IF (X.LE.12.0D0) THEN + BJ0=1.0D0 + R=1.0D0 + DO 5 K=1,30 + R=-0.25D0*R*X2/(K*K) + BJ0=BJ0+R + IF (DABS(R).LT.DABS(BJ0)*1.0D-15) GO TO 10 +5 CONTINUE +10 BJ1=1.0D0 + R=1.0D0 + DO 15 K=1,30 + R=-0.25D0*R*X2/(K*(K+1.0D0)) + BJ1=BJ1+R + IF (DABS(R).LT.DABS(BJ1)*1.0D-15) GO TO 20 +15 CONTINUE +20 BJ1=0.5D0*X*BJ1 + EC=DLOG(X/2.0D0)+0.5772156649015329D0 + CS0=0.0D0 + W0=0.0D0 + R0=1.0D0 + DO 25 K=1,30 + W0=W0+1.0D0/K + R0=-0.25D0*R0/(K*K)*X2 + R=R0*W0 + CS0=CS0+R + IF (DABS(R).LT.DABS(CS0)*1.0D-15) GO TO 30 +25 CONTINUE +30 BY0=RP2*(EC*BJ0-CS0) + CS1=1.0D0 + W1=0.0D0 + R1=1.0D0 + DO 35 K=1,30 + W1=W1+1.0D0/K + R1=-0.25D0*R1/(K*(K+1))*X2 + R=R1*(2.0D0*W1+1.0D0/(K+1.0D0)) + CS1=CS1+R + IF (DABS(R).LT.DABS(CS1)*1.0D-15) GO TO 40 +35 CONTINUE +40 BY1=RP2*(EC*BJ1-1.0D0/X-0.25D0*X*CS1) + ELSE + DATA A/-.7031250000000000D-01,.1121520996093750D+00, + & -.5725014209747314D+00,.6074042001273483D+01, + & -.1100171402692467D+03,.3038090510922384D+04, + & -.1188384262567832D+06,.6252951493434797D+07, + & -.4259392165047669D+09,.3646840080706556D+11, + & -.3833534661393944D+13,.4854014686852901D+15/ + DATA B/ .7324218750000000D-01,-.2271080017089844D+00, + & .1727727502584457D+01,-.2438052969955606D+02, + & .5513358961220206D+03,-.1825775547429318D+05, + & .8328593040162893D+06,-.5006958953198893D+08, + & .3836255180230433D+10,-.3649010818849833D+12, + & .4218971570284096D+14,-.5827244631566907D+16/ + DATA A1/.1171875000000000D+00,-.1441955566406250D+00, + & .6765925884246826D+00,-.6883914268109947D+01, + & .1215978918765359D+03,-.3302272294480852D+04, + & .1276412726461746D+06,-.6656367718817688D+07, + & .4502786003050393D+09,-.3833857520742790D+11, + & .4011838599133198D+13,-.5060568503314727D+15/ + DATA B1/-.1025390625000000D+00,.2775764465332031D+00, + & -.1993531733751297D+01,.2724882731126854D+02, + & -.6038440767050702D+03,.1971837591223663D+05, + & -.8902978767070678D+06,.5310411010968522D+08, + & -.4043620325107754D+10,.3827011346598605D+12, + & -.4406481417852278D+14,.6065091351222699D+16/ + K0=12 + IF (X.GE.35.0) K0=10 + IF (X.GE.50.0) K0=8 + T1=X-0.25D0*PI + P0=1.0D0 + Q0=-0.125D0/X + DO 45 K=1,K0 + P0=P0+A(K)*X**(-2*K) +45 Q0=Q0+B(K)*X**(-2*K-1) + CU=DSQRT(RP2/X) + BJ0=CU*(P0*DCOS(T1)-Q0*DSIN(T1)) + BY0=CU*(P0*DSIN(T1)+Q0*DCOS(T1)) + T2=X-0.75D0*PI + P1=1.0D0 + Q1=0.375D0/X + DO 50 K=1,K0 + P1=P1+A1(K)*X**(-2*K) +50 Q1=Q1+B1(K)*X**(-2*K-1) + CU=DSQRT(RP2/X) + BJ1=CU*(P1*DCOS(T2)-Q1*DSIN(T2)) + BY1=CU*(P1*DSIN(T2)+Q1*DCOS(T2)) + ENDIF + DJ0=-BJ1 + DJ1=BJ0-BJ1/X + DY0=-BY1 + DY1=BY0-BY1/X + RETURN + END diff --git a/src/metrics/Gowdy_wave.F77 b/src/metrics/Gowdy_wave.F77 deleted file mode 100644 index efdb938..0000000 --- a/src/metrics/Gowdy_wave.F77 +++ /dev/null @@ -1,244 +0,0 @@ -C @@ -C @file Gowdy.F77 -C @date December 2002 -C @author Denis Pollney -C @desc -C Cosmological Gowdy metric for a polarized wave in an -C expanding universe. See -C "Stable 3-level leapfrog integration in numerical relativity" -C New, K, Watt, K, Misner, C and Centrella, J, PRD 58, 064022. -C @desc -C @version $Header$ -C @@ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Gowdy_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local static variables - logical firstcall - CCTK_REAL amp - CCTK_REAL PI, twoPI - CCTK_REAL Bessel_J0, Bessel_J1 - data firstcall /.true./ - save firstcall, amp, PI, twoPI, Bessel_J0, Bessel_J1 -c$omp threadprivate (firstcall, amp, PI, twoPI, Bessel_J0, Bessel_J1) - -c local variables - CCTK_REAL Bessel_J0_t, Bessel_J1_t - CCTK_REAL cosz, eP, lambda - CCTK_REAL d1, d2, d3, d4, d5, d6 - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - - if (firstcall) then - amp = Gowdy_wave__amplitude - PI = acos(-1.d0) - twoPI = 2.d0*PI - call jy01a(twoPI, Bessel_J0, d1, Bessel_J1, d2, d3, d4, d5, d6) - firstcall = .false. - end if - - if (t.eq.0.d0) then - call CCTK_WARN(0, "The Gowdy metric is singular for t=0. You may need to set cactus::cctk_initial_time > 0.") - end if - - call jy01a(twoPI*t, Bessel_J0_t, d1, Bessel_J1_t, d2, d3, d4, d5, d6) - - cosz = cos(twoPI*z) - eP = exp(Bessel_J0_t * cosz) - - lambda = amp * (-twoPI * t * Bessel_J0_t * Bessel_J1_t * cosz**2 - + + twoPI * PI * t**2 * (Bessel_J0_t**2 + Bessel_J1_t**2) - + - 0.5d0 * (twoPI**2 * (Bessel_J0**2 + Bessel_J1**2) - + - twoPI * Bessel_J0 * Bessel_J1)) -c -c lower metric components. -c - gdtt = -exp(0.5d0*lambda)/sqrt(t) - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = t * eP - gdyy = t / eP - gdzz = -gdtt - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - -c -c upper metric components. -c - gutt = 1.d0 / gdtt - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = 1.d0 / gdxx - guyy = 1.d0 / gdyy - guzz = 1.d0 / gdzz - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - return - end - -C @@ -C @routine Bessel.F77 -C @date December 2002 -C @author Denis Pollney -C @desc -C Compute bessel functions of 0th and 1st order. -C This routine was downloaded from: -C http://iris-lee3.ece.uiuc.edu/~jjin/routines/routines.html -C -C ======================================================= -C Purpose: Compute Bessel functions J0(x), J1(x), Y0(x), -C Y1(x), and their derivatives -C Input : x --- Argument of Jn(x) & Yn(x) ( x ? 0 ) -C Output: BJ0 --- J0(x) -C DJ0 --- dJ0(x) -C BJ1 --- J1(x) -C DJ1 --- dJ1(x) -C BY0 --- Y0(x) -C DY0 --- dY0(x) -C BY1 --- Y1(x) -C DY1 --- dY1(x) -C ======================================================= -C -C @desc -C @version $Header$ -C @@ - - SUBROUTINE JY01A(X,BJ0,DJ0,BJ1,DJ1,BY0,DY0,BY1,DY1) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION A(12),B(12),A1(12),B1(12) - PI=3.141592653589793D0 - RP2=0.63661977236758D0 - X2=X*X - IF (X.EQ.0.0D0) THEN - BJ0=1.0D0 - BJ1=0.0D0 - DJ0=0.0D0 - DJ1=0.5D0 - BY0=-1.0D+300 - BY1=-1.0D+300 - DY0=1.0D+300 - DY1=1.0D+300 - RETURN - ENDIF - IF (X.LE.12.0D0) THEN - BJ0=1.0D0 - R=1.0D0 - DO 5 K=1,30 - R=-0.25D0*R*X2/(K*K) - BJ0=BJ0+R - IF (DABS(R).LT.DABS(BJ0)*1.0D-15) GO TO 10 -5 CONTINUE -10 BJ1=1.0D0 - R=1.0D0 - DO 15 K=1,30 - R=-0.25D0*R*X2/(K*(K+1.0D0)) - BJ1=BJ1+R - IF (DABS(R).LT.DABS(BJ1)*1.0D-15) GO TO 20 -15 CONTINUE -20 BJ1=0.5D0*X*BJ1 - EC=DLOG(X/2.0D0)+0.5772156649015329D0 - CS0=0.0D0 - W0=0.0D0 - R0=1.0D0 - DO 25 K=1,30 - W0=W0+1.0D0/K - R0=-0.25D0*R0/(K*K)*X2 - R=R0*W0 - CS0=CS0+R - IF (DABS(R).LT.DABS(CS0)*1.0D-15) GO TO 30 -25 CONTINUE -30 BY0=RP2*(EC*BJ0-CS0) - CS1=1.0D0 - W1=0.0D0 - R1=1.0D0 - DO 35 K=1,30 - W1=W1+1.0D0/K - R1=-0.25D0*R1/(K*(K+1))*X2 - R=R1*(2.0D0*W1+1.0D0/(K+1.0D0)) - CS1=CS1+R - IF (DABS(R).LT.DABS(CS1)*1.0D-15) GO TO 40 -35 CONTINUE -40 BY1=RP2*(EC*BJ1-1.0D0/X-0.25D0*X*CS1) - ELSE - DATA A/-.7031250000000000D-01,.1121520996093750D+00, - & -.5725014209747314D+00,.6074042001273483D+01, - & -.1100171402692467D+03,.3038090510922384D+04, - & -.1188384262567832D+06,.6252951493434797D+07, - & -.4259392165047669D+09,.3646840080706556D+11, - & -.3833534661393944D+13,.4854014686852901D+15/ - DATA B/ .7324218750000000D-01,-.2271080017089844D+00, - & .1727727502584457D+01,-.2438052969955606D+02, - & .5513358961220206D+03,-.1825775547429318D+05, - & .8328593040162893D+06,-.5006958953198893D+08, - & .3836255180230433D+10,-.3649010818849833D+12, - & .4218971570284096D+14,-.5827244631566907D+16/ - DATA A1/.1171875000000000D+00,-.1441955566406250D+00, - & .6765925884246826D+00,-.6883914268109947D+01, - & .1215978918765359D+03,-.3302272294480852D+04, - & .1276412726461746D+06,-.6656367718817688D+07, - & .4502786003050393D+09,-.3833857520742790D+11, - & .4011838599133198D+13,-.5060568503314727D+15/ - DATA B1/-.1025390625000000D+00,.2775764465332031D+00, - & -.1993531733751297D+01,.2724882731126854D+02, - & -.6038440767050702D+03,.1971837591223663D+05, - & -.8902978767070678D+06,.5310411010968522D+08, - & -.4043620325107754D+10,.3827011346598605D+12, - & -.4406481417852278D+14,.6065091351222699D+16/ - K0=12 - IF (X.GE.35.0) K0=10 - IF (X.GE.50.0) K0=8 - T1=X-0.25D0*PI - P0=1.0D0 - Q0=-0.125D0/X - DO 45 K=1,K0 - P0=P0+A(K)*X**(-2*K) -45 Q0=Q0+B(K)*X**(-2*K-1) - CU=DSQRT(RP2/X) - BJ0=CU*(P0*DCOS(T1)-Q0*DSIN(T1)) - BY0=CU*(P0*DSIN(T1)+Q0*DCOS(T1)) - T2=X-0.75D0*PI - P1=1.0D0 - Q1=0.375D0/X - DO 50 K=1,K0 - P1=P1+A1(K)*X**(-2*K) -50 Q1=Q1+B1(K)*X**(-2*K-1) - CU=DSQRT(RP2/X) - BJ1=CU*(P1*DCOS(T2)-Q1*DSIN(T2)) - BY1=CU*(P1*DSIN(T2)+Q1*DCOS(T2)) - ENDIF - DJ0=-BJ1 - DJ1=BJ0-BJ1/X - DY0=-BY1 - DY1=BY0-BY1/X - RETURN - END diff --git a/src/metrics/Kasner_axisymmetric.F b/src/metrics/Kasner_axisymmetric.F new file mode 100644 index 0000000..aa798a8 --- /dev/null +++ b/src/metrics/Kasner_axisymmetric.F @@ -0,0 +1,65 @@ +C Axisymmetric Kasner solution ! +C +C Author : D. Vulcanov +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Kasner_axisymmetric( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL t + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + + gdtt = -t**(-0.5d0) + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = t**(-0.5d0) + gdyy = t + gdzz = t + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = -t**(0.5d0) + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = t**(0.5d0) + guyy = 1.d0/t + guzz = 1.d0/t + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + + + return + end diff --git a/src/metrics/Kasner_axisymmetric.F77 b/src/metrics/Kasner_axisymmetric.F77 deleted file mode 100644 index 0cf292a..0000000 --- a/src/metrics/Kasner_axisymmetric.F77 +++ /dev/null @@ -1,62 +0,0 @@ -C Axisymmetric Kasner solution ! -C -C Author : D. Vulcanov -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Kasner_axisymmetric( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - - gdtt = -t**(-0.5d0) - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = t**(-0.5d0) - gdyy = t - gdzz = t - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = -t**(0.5d0) - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = t**(0.5d0) - guyy = 1.d0/t - guzz = 1.d0/t - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - - - return - end diff --git a/src/metrics/Kasner_generalized.F b/src/metrics/Kasner_generalized.F new file mode 100644 index 0000000..e0f0a82 --- /dev/null +++ b/src/metrics/Kasner_generalized.F @@ -0,0 +1,75 @@ +C Kasner generalized metric spacetime !!!! +C +C Author : D. Vulcanov +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Kasner_generalized( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL t + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL pp1,pp2,a1,a2,a3 + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .true. + + pp1= Kasner_generalized__p1 + pp2= Kasner_generalized__p2 + + a1= t**(2.d0*pp1) + a2= t**(2.d0*pp2) + a3= t**(2.d0-2.d0*pp1-2.d0*pp2) + + + gdtt = -1.d0 + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = a1 + gdyy = a2 + gdzz = a3 + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = -1.d0 + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = 1.d0/a1 + guyy = 1.d0/a2 + guzz = 1.d0/a3 + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + + return + end diff --git a/src/metrics/Kasner_generalized.F77 b/src/metrics/Kasner_generalized.F77 deleted file mode 100644 index fe29330..0000000 --- a/src/metrics/Kasner_generalized.F77 +++ /dev/null @@ -1,72 +0,0 @@ -C Kasner generalized metric spacetime !!!! -C -C Author : D. Vulcanov -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Kasner_generalized( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL pp1,pp2,a1,a2,a3 - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .true. - - pp1= Kasner_generalized__p1 - pp2= Kasner_generalized__p2 - - a1= t**(2.d0*pp1) - a2= t**(2.d0*pp2) - a3= t**(2.d0-2.d0*pp1-2.d0*pp2) - - - gdtt = -1.d0 - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = a1 - gdyy = a2 - gdzz = a3 - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = -1.d0 - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = 1.d0/a1 - guyy = 1.d0/a2 - guzz = 1.d0/a3 - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - - return - end diff --git a/src/metrics/Kasner_like.F b/src/metrics/Kasner_like.F new file mode 100644 index 0000000..26de7cd --- /dev/null +++ b/src/metrics/Kasner_like.F @@ -0,0 +1,77 @@ +C Kasner-like metric spacetime !!!! +C See: L. Pimentel, Int. Journ. of Theor. Physics, +C, vol. 32, No. 6, 1993, p. 979 (and the references +C cited here), and S. Gotlober, et. al. Early Evolution +C of the Universe and Formation Structure, Akad. Verlag, 1990 +C +C Author : D. Vulcanov +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Kasner_like( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL t + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL qq,a1,a3 + +c this model sets the stress-energy tensor in the "CalcTmunu" code + Tmunu_flag = .true. + + qq = Kasner_like__q + + a1= t**(2.d0*qq) + a3= t**(2.d0-4.d0*qq) + + + gdtt = -1.d0 + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = a1 + gdyy = a1 + gdzz = a3 + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = -1.d0 + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = 1.d0/a1 + guyy = 1.d0/a1 + guzz = 1.d0/a3 + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + + return + end diff --git a/src/metrics/Kasner_like.F77 b/src/metrics/Kasner_like.F77 deleted file mode 100644 index 7c7b57e..0000000 --- a/src/metrics/Kasner_like.F77 +++ /dev/null @@ -1,74 +0,0 @@ -C Kasner-like metric spacetime !!!! -C See: L. Pimentel, Int. Journ. of Theor. Physics, -C, vol. 32, No. 6, 1993, p. 979 (and the references -C cited here), and S. Gotlober, et. al. Early Evolution -C of the Universe and Formation Structure, Akad. Verlag, 1990 -C -C Author : D. Vulcanov -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Kasner_like( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL qq,a1,a3 - -c this model sets the stress-energy tensor in the "CalcTmunu" code - Tmunu_flag = .true. - - qq = Kasner_like__q - - a1= t**(2.d0*qq) - a3= t**(2.d0-4.d0*qq) - - - gdtt = -1.d0 - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = a1 - gdyy = a1 - gdzz = a3 - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = -1.d0 - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = 1.d0/a1 - guyy = 1.d0/a1 - guzz = 1.d0/a3 - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - - return - end diff --git a/src/metrics/Kerr_BoyerLindquist.F b/src/metrics/Kerr_BoyerLindquist.F new file mode 100644 index 0000000..5c3c933 --- /dev/null +++ b/src/metrics/Kerr_BoyerLindquist.F @@ -0,0 +1,68 @@ +C Kerr metric in cartesian Boyer-Lindquist coordinates, +C as per MTW box 33.2. +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Kerr_BoyerLindquist( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y + CCTK_DECLARE(CCTK_REAL, z,) + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + + CCTK_REAL arad, marad + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + + arad = Kerr_BoyerLindquist__spin + marad = Kerr_BoyerLindquist__mass + + gdtt = -(y**2*arad**2+x**2-2*marad*x)/(x**2+y**2*arad**2) + gdtx = 2*(arad*marad*x*(y**2-1))/(x**2+y**2*arad**2) + gdty = 0.d0 + gdtz = 0.d0 + gdxx = -(x**4+x**2*arad**2+2*arad**2*marad*x+arad**2*y**2*x**2 - 2*arad**2*y**2*marad*x+arad**4*y**2)*(y**2-1)/(x**2+arad**2*y**2) + gdyy = (x**2+y**2*arad**2)/(x**2-2*marad*x+arad**2) + gdzz = -(x**2+y**2*arad**2)/(y**2-1) + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = -(-x**4-x**2*arad**2-2*arad**2*marad*x-arad**2*y**2*x**2 +2*arad**2*y**2*marad*x-arad**4*y**2)/((x**2+arad**2*y**2)*(-x**2+2*marad*x-arad**2)) + gutx = 2*(arad*marad*x)/((x**2+arad**2*y**2)*(-x**2+2*marad*x-arad**2)) + guty = 0.d0 + gutz = 0.d0 + guxx = -(-arad**2*y**2-x**2+2*marad*x)/((x**2+arad**2*y**2)*(y**2-1)*(-x**2+2*marad*x-arad**2)) + guyy = -(-x**2+2*marad*x-arad**2)/(x**2+arad**2*y**2) + guzz = -(y**2-1)/(x**2+arad**2*y**2) + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + return + end diff --git a/src/metrics/Kerr_BoyerLindquist.F77 b/src/metrics/Kerr_BoyerLindquist.F77 deleted file mode 100644 index 0a8c25f..0000000 --- a/src/metrics/Kerr_BoyerLindquist.F77 +++ /dev/null @@ -1,66 +0,0 @@ -C Kerr metric in cartesian Boyer-Lindquist coordinates, -C as per MTW box 33.2. -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Kerr_BoyerLindquist( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - - CCTK_REAL arad, marad - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - - arad = Kerr_BoyerLindquist__spin - marad = Kerr_BoyerLindquist__mass - - gdtt = -(y**2*arad**2+x**2-2*marad*x)/(x**2+y**2*arad**2) - gdtx = 2*(arad*marad*x*(y**2-1))/(x**2+y**2*arad**2) - gdty = 0.d0 - gdtz = 0.d0 - gdxx = -(x**4+x**2*arad**2+2*arad**2*marad*x+arad**2*y**2*x**2 - 2*arad**2*y**2*marad*x+arad**4*y**2)*(y**2-1)/(x**2+arad**2*y**2) - gdyy = (x**2+y**2*arad**2)/(x**2-2*marad*x+arad**2) - gdzz = -(x**2+y**2*arad**2)/(y**2-1) - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = -(-x**4-x**2*arad**2-2*arad**2*marad*x-arad**2*y**2*x**2 +2*arad**2*y**2*marad*x-arad**4*y**2)/((x**2+arad**2*y**2)*(-x**2+2*marad*x-arad**2)) - gutx = 2*(arad*marad*x)/((x**2+arad**2*y**2)*(-x**2+2*marad*x-arad**2)) - guty = 0.d0 - gutz = 0.d0 - guxx = -(-arad**2*y**2-x**2+2*marad*x)/((x**2+arad**2*y**2)*(y**2-1)*(-x**2+2*marad*x-arad**2)) - guyy = -(-x**2+2*marad*x-arad**2)/(x**2+arad**2*y**2) - guzz = -(y**2-1)/(x**2+arad**2*y**2) - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - return - end diff --git a/src/metrics/Kerr_KerrSchild.F b/src/metrics/Kerr_KerrSchild.F new file mode 100644 index 0000000..36ea76f --- /dev/null +++ b/src/metrics/Kerr_KerrSchild.F @@ -0,0 +1,157 @@ +C Kerr-Schild form of boosted rotating black hole. +C Program g_ab = eta_ab + H l_a l_b, g^ab = eta^ab - H l^a l^b. +C Here eta_ab is Minkowski in Cartesian coordinates, H is a scalar, +C and l is a null vector. +C +C Author: unknown +C Copyright/License: unknown +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + + subroutine Exact__Kerr_KerrSchild( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL boostv, eps, m, a + integer power + +c local variables + CCTK_REAL gamma, t0, z0, x0, y0, rho02, r02, r0, costheta0, + $ lt0, lx0, ly0, lz0, hh, lt, lx, ly, lz + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution, +C and convert from parameter file spin parameter J/m^2 +C to the J/m definition used in the code here. + + boostv = Kerr_KerrSchild__boost_v + eps = Kerr_KerrSchild__epsilon + power = Kerr_KerrSchild__power + m = Kerr_KerrSchild__mass + a = m*Kerr_KerrSchild__spin + +C Boost factor. + + gamma = 1.d0 / sqrt(1.d0 - boostv**2) + +C Lorentz transform t,x,y,z -> t0,x0,y0,z0. +C t0 is never used, but is here for illustration, and we introduce +C x0 and y0 also only for clarity. +C Note that z0 = 0 means z = vt for the BH. + + t0 = gamma * ((t - Kerr_KerrSchild__t) - boostv * (z - Kerr_KerrSchild__z)) + z0 = gamma * ((z - Kerr_KerrSchild__z) - boostv * (t - Kerr_KerrSchild__t)) + x0 = x - Kerr_KerrSchild__x + y0 = y - Kerr_KerrSchild__y + +C Coordinate distance to center of black hole. Note it moves! + + rho02 = x0**2 + y0**2 + z0**2 + +C Spherical auxiliary coordinate r and angle theta in BH rest frame. + + r02 = 0.5d0 * (rho02 - a**2) + $ + sqrt(0.25d0 * (rho02 - a**2)**2 + a**2 * z0**2) + r0 = sqrt(max(0.0d0,r02)) + if (Kerr_KerrSchild__parabolic .eq. 0) then +C Use a power law to avoid the singularity + r0 = (r0**power + eps**power)**(1.0d0/power) + else + if (r0 .lt. eps) then + if (power .eq. 0) then + r0 = eps + else if (power .eq. 2) then + r0 = eps/2 + r0**2 * 1/(2*eps) + else if (power .eq. 4) then + r0 = 3*eps/8 + r0**2 * (3/(4*eps) - r0**2 * 1/(8*eps**3)) + else if (power .eq. 6) then + r0 = 5*eps/16 + r0**2 * (15/(16*eps) + r0**2 * (-5/(16*eps**3) + r0**2 * 1/(16*eps**5))) + else if (power .eq. 8) then + r0 = 35*eps/128 + r0**2 * (35/(32*eps) + r0**2 * (-35/(64*eps**3) + r0**2 * (7/(32*eps**5) - r0**2 * 5/(128*eps**7)))) + else + call CCTK_WARN (CCTK_WARN_ABORT, "Unsupported value of parameter Kerr_KerrSchild__power") + end if + end if + end if +C Another idea: +C r0 = r0 + eps * exp(-x/eps) + + costheta0 = z0 / r0 + +C Coefficient H. Note this transforms as a scalar, so does not carry +C the suffix 0. + hh = m * r0 / (r0**2 + a**2 * costheta0**2) + +C Components of l_a in rest frame. Note indices down. + lt0 = 1.d0 + lx0 = (r0 * x0 + a * y0) / (r0**2 + a**2) + ly0 = (r0 * y0 - a * x0) / (r0**2 + a**2) + lz0 = z0 / r0 + +C Now boost it to coordinates x, y, z, t. +C This is the reverse Lorentz transformation, but applied +C to a one-form, so the sign of boostv is the same as the forward +C Lorentz transformation applied to the coordinates. + + lt = gamma * (lt0 - boostv * lz0) + lz = gamma * (lz0 - boostv * lt0) + lx = lx0 + ly = ly0 + +C Down metric. g_ab = flat_ab + H l_a l_b + + gdtt = - 1.d0 + 2.d0 * hh * lt * lt + gdtx = 2.d0 * hh * lt * lx + gdty = 2.d0 * hh * lt * ly + gdtz = 2.d0 * hh * lt * lz + gdxx = 1.d0 + 2.d0 * hh * lx * lx + gdyy = 1.d0 + 2.d0 * hh * ly * ly + gdzz = 1.d0 + 2.d0 * hh * lz * lz + gdxy = 2.d0 * hh * lx * ly + gdyz = 2.d0 * hh * ly * lz + gdzx = 2.d0 * hh * lz * lx + +C Up metric. g^ab = flat^ab - H l^a l^b. +C Notice that g^ab = g_ab and l^i = l_i and l^0 = - l_0 in flat spacetime. + gutt = - 1.d0 - 2.d0 * hh * lt * lt + gutx = 2.d0 * hh * lt * lx + guty = 2.d0 * hh * lt * ly + gutz = 2.d0 * hh * lt * lz + guxx = 1.d0 - 2.d0 * hh * lx * lx + guyy = 1.d0 - 2.d0 * hh * ly * ly + guzz = 1.d0 - 2.d0 * hh * lz * lz + guxy = - 2.d0 * hh * lx * ly + guyz = - 2.d0 * hh * ly * lz + guzx = - 2.d0 * hh * lz * lx + + return + end diff --git a/src/metrics/Kerr_KerrSchild.F77 b/src/metrics/Kerr_KerrSchild.F77 deleted file mode 100644 index ee1e077..0000000 --- a/src/metrics/Kerr_KerrSchild.F77 +++ /dev/null @@ -1,157 +0,0 @@ -C Kerr-Schild form of boosted rotating black hole. -C Program g_ab = eta_ab + H l_a l_b, g^ab = eta^ab - H l^a l^b. -C Here eta_ab is Minkowski in Cartesian coordinates, H is a scalar, -C and l is a null vector. -C -C Author: unknown -C Copyright/License: unknown -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - - subroutine Exact__Kerr_KerrSchild( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL boostv, eps, m, a - integer power - -c local variables - CCTK_REAL gamma, t0, z0, x0, y0, rho02, r02, r0, costheta0, - $ lt0, lx0, ly0, lz0, hh, lt, lx, ly, lz - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution, -C and convert from parameter file spin parameter J/m^2 -C to the J/m definition used in the code here. - - boostv = Kerr_KerrSchild__boost_v - eps = Kerr_KerrSchild__epsilon - power = Kerr_KerrSchild__power - m = Kerr_KerrSchild__mass - a = m*Kerr_KerrSchild__spin - -C Boost factor. - - gamma = 1.d0 / sqrt(1.d0 - boostv**2) - -C Lorentz transform t,x,y,z -> t0,x0,y0,z0. -C t0 is never used, but is here for illustration, and we introduce -C x0 and y0 also only for clarity. -C Note that z0 = 0 means z = vt for the BH. - - t0 = gamma * ((t - Kerr_KerrSchild__t) - boostv * (z - Kerr_KerrSchild__z)) - z0 = gamma * ((z - Kerr_KerrSchild__z) - boostv * (t - Kerr_KerrSchild__t)) - x0 = x - Kerr_KerrSchild__x - y0 = y - Kerr_KerrSchild__y - -C Coordinate distance to center of black hole. Note it moves! - - rho02 = x0**2 + y0**2 + z0**2 - -C Spherical auxiliary coordinate r and angle theta in BH rest frame. - - r02 = 0.5d0 * (rho02 - a**2) - $ + sqrt(0.25d0 * (rho02 - a**2)**2 + a**2 * z0**2) - r0 = sqrt(max(0.0d0,r02)) - if (Kerr_KerrSchild__parabolic .eq. 0) then -C Use a power law to avoid the singularity - r0 = (r0**power + eps**power)**(1.0d0/power) - else - if (r0 .lt. eps) then - if (power .eq. 0) then - r0 = eps - else if (power .eq. 2) then - r0 = eps/2 + r0**2 * 1/(2*eps) - else if (power .eq. 4) then - r0 = 3*eps/8 + r0**2 * (3/(4*eps) - r0**2 * 1/(8*eps**3)) - else if (power .eq. 6) then - r0 = 5*eps/16 + r0**2 * (15/(16*eps) + r0**2 * (-5/(16*eps**3) + r0**2 * 1/(16*eps**5))) - else if (power .eq. 8) then - r0 = 35*eps/128 + r0**2 * (35/(32*eps) + r0**2 * (-35/(64*eps**3) + r0**2 * (7/(32*eps**5) - r0**2 * 5/(128*eps**7)))) - else - call CCTK_WARN (CCTK_WARN_ABORT, "Unsupported value of parameter Kerr_KerrSchild__power") - end if - end if - end if -C Another idea: -C r0 = r0 + eps * exp(-x/eps) - - costheta0 = z0 / r0 - -C Coefficient H. Note this transforms as a scalar, so does not carry -C the suffix 0. - hh = m * r0 / (r0**2 + a**2 * costheta0**2) - -C Components of l_a in rest frame. Note indices down. - lt0 = 1.d0 - lx0 = (r0 * x0 + a * y0) / (r0**2 + a**2) - ly0 = (r0 * y0 - a * x0) / (r0**2 + a**2) - lz0 = z0 / r0 - -C Now boost it to coordinates x, y, z, t. -C This is the reverse Lorentz transformation, but applied -C to a one-form, so the sign of boostv is the same as the forward -C Lorentz transformation applied to the coordinates. - - lt = gamma * (lt0 - boostv * lz0) - lz = gamma * (lz0 - boostv * lt0) - lx = lx0 - ly = ly0 - -C Down metric. g_ab = flat_ab + H l_a l_b - - gdtt = - 1.d0 + 2.d0 * hh * lt * lt - gdtx = 2.d0 * hh * lt * lx - gdty = 2.d0 * hh * lt * ly - gdtz = 2.d0 * hh * lt * lz - gdxx = 1.d0 + 2.d0 * hh * lx * lx - gdyy = 1.d0 + 2.d0 * hh * ly * ly - gdzz = 1.d0 + 2.d0 * hh * lz * lz - gdxy = 2.d0 * hh * lx * ly - gdyz = 2.d0 * hh * ly * lz - gdzx = 2.d0 * hh * lz * lx - -C Up metric. g^ab = flat^ab - H l^a l^b. -C Notice that g^ab = g_ab and l^i = l_i and l^0 = - l_0 in flat spacetime. - gutt = - 1.d0 - 2.d0 * hh * lt * lt - gutx = 2.d0 * hh * lt * lx - guty = 2.d0 * hh * lt * ly - gutz = 2.d0 * hh * lt * lz - guxx = 1.d0 - 2.d0 * hh * lx * lx - guyy = 1.d0 - 2.d0 * hh * ly * ly - guzz = 1.d0 - 2.d0 * hh * lz * lz - guxy = - 2.d0 * hh * lx * ly - guyz = - 2.d0 * hh * ly * lz - guzx = - 2.d0 * hh * lz * lx - - return - end diff --git a/src/metrics/Kerr_KerrSchild_spherical.F b/src/metrics/Kerr_KerrSchild_spherical.F new file mode 100644 index 0000000..02d356d --- /dev/null +++ b/src/metrics/Kerr_KerrSchild_spherical.F @@ -0,0 +1,182 @@ +C Kerr-Schild form of boosted rotating black hole. +C Program g_ab = eta_ab + H l_a l_b, g^ab = eta^ab - H l^a l^b. +C Here eta_ab is Minkowski in Cartesian coordinates, H is a scalar, +C and l is a null vector. +C +C The coordinates are distorted, such that the event horizon is +C a coordinate sphere. +C +C Author: Erik Schnetter +C This formulation was invented by Nils Dorband +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + + subroutine Exact__Kerr_KerrSchild_spherical ( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL boostv, eps, m, a + +c local variables + CCTK_REAL t1, x1, y1, z1, rho1, + $ gamma, t0, z0, x0, y0, r0, costheta0, + $ lt0, lx0, ly0, lz0, hh, lt, lx, ly, lz + + CCTK_REAL gd(3,3), gdt(3,3), det, jac(3,3) + + integer i, j, k, l + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution, +C and convert from parameter file spin parameter J/m^2 +C to the J/m definition used in the code here. + + boostv = Kerr_KerrSchild__boost_v + eps = Kerr_KerrSchild__epsilon + m = Kerr_KerrSchild__mass + a = m*Kerr_KerrSchild__spin + +C Distort the coordinates such that the event horizon is a +C coordinate sphere + rho1 = sqrt (x**2 + y**2 + z**2) + rho1 = (rho1**4 + eps**4) ** 0.25d0 + t1 = t + x1 = x - a * y / rho1 + y1 = y + a * x / rho1 + z1 = z + +C Boost factor. + + gamma = 1 / sqrt(1 - boostv**2) + +C Lorentz transform t,x,y,z -> t0,x0,y0,z0. +C t0 is never used, but is here for illustration, and we introduce +C x0 and y0 also only for clarity. +C Note that z0 = 0 means z = vt for the BH. + + t0 = gamma * ((t1 - Kerr_KerrSchild__t) - boostv * (z1 - Kerr_KerrSchild__z)) + z0 = gamma * ((z1 - Kerr_KerrSchild__z) - boostv * (t1 - Kerr_KerrSchild__t)) + x0 = x1 - Kerr_KerrSchild__x + y0 = y1 - Kerr_KerrSchild__y + +C Spherical auxiliary coordinate r and angle theta in BH rest frame. + + r0 = rho1 + costheta0 = z0 / r0 + +C Coefficient H. Note this transforms as a scalar, so does not carry +C the suffix 0. + hh = m * r0 / (r0**2 + a**2 * costheta0**2) + +C Components of l_a in rest frame. Note indices down. + lt0 = 1.d0 + lx0 = (r0 * x0 + a * y0) / (r0**2 + a**2) + ly0 = (r0 * y0 - a * x0) / (r0**2 + a**2) + lz0 = z0 / r0 + +C Now boost it to coordinates x, y, z, t. +C This is the reverse Lorentz transformation, but applied +C to a one-form, so the sign of boostv is the same as the forward +C Lorentz transformation applied to the coordinates. + + lt = gamma * (lt0 - boostv * lz0) + lz = gamma * (lz0 - boostv * lt0) + lx = lx0 + ly = ly0 + +C Down metric. g_ab = flat_ab + H l_a l_b + + gdtt = - 1.d0 + 2.d0 * hh * lt * lt + gdtx = 2.d0 * hh * lt * lx + gdty = 2.d0 * hh * lt * ly + gdtz = 2.d0 * hh * lt * lz + + gd(1,1) = 1.d0 + 2.d0 * hh * lx * lx + gd(2,2) = 1.d0 + 2.d0 * hh * ly * ly + gd(3,3) = 1.d0 + 2.d0 * hh * lz * lz + gd(1,2) = 2.d0 * hh * lx * ly + gd(2,3) = 2.d0 * hh * ly * lz + gd(3,1) = 2.d0 * hh * lz * lx + gd(2,1) = gd(1,2) + gd(3,2) = gd(2,3) + gd(1,3) = gd(3,1) + +C Transform the tensor basis back + jac(1,1) = 1 + (a*x*y) / (rho1**3) + jac(1,2) = - a * (x**2+z**2) / (rho1**3) + jac(1,3) = a*y*z / (rho1**3) + + jac(2,1) = a * (y**2+z**2) / (rho1**3) + jac(2,2) = 1 - a*x*y / (rho1**3) + jac(2,3) = - a*x*z / (rho1**3) + + jac(3,1) = 0 + jac(3,2) = 0 + jac(3,3) = 1 + + do i = 1, 3 + do j = 1, 3 + gdt(i,j) = 0 + do k = 1, 3 + do l = 1, 3 + gdt(i,j) = gdt(i,j) + gd(k,l) * jac(k,i) * jac(l,j) + end do + end do + end do + end do + + gdxx = gdt(1,1) + gdyy = gdt(2,2) + gdzz = gdt(3,3) + gdxy = gdt(1,2) + gdyz = gdt(2,3) + gdzx = gdt(3,1) + +C Up metric. g^ab = flat^ab - H l^a l^b. +C Notice that g^ab = g_ab and l^i = l_i and l^0 = - l_0 in flat spacetime. + gutt = - 1.d0 - 2.d0 * hh * lt * lt + gutx = 2.d0 * hh * lt * lx + guty = 2.d0 * hh * lt * ly + gutz = 2.d0 * hh * lt * lz + + det = gdxx*gdyy*gdzz + 2*gdxy*gdzx*gdyz + . - gdxx*gdyz**2 - gdyy*gdzx**2 - gdzz*gdxy**2 + + guxx = (gdyy*gdzz - gdyz**2)/det + guyy = (gdxx*gdzz - gdzx**2)/det + guzz = (gdxx*gdyy - gdxy**2)/det + + guxy = (gdzx*gdyz - gdzz*gdxy)/det + guyz = (gdxy*gdzx - gdxx*gdyz)/det + guzx = (gdxy*gdyz - gdyy*gdzx)/det + + end diff --git a/src/metrics/Kerr_KerrSchild_spherical.F77 b/src/metrics/Kerr_KerrSchild_spherical.F77 deleted file mode 100644 index 417b224..0000000 --- a/src/metrics/Kerr_KerrSchild_spherical.F77 +++ /dev/null @@ -1,182 +0,0 @@ -C Kerr-Schild form of boosted rotating black hole. -C Program g_ab = eta_ab + H l_a l_b, g^ab = eta^ab - H l^a l^b. -C Here eta_ab is Minkowski in Cartesian coordinates, H is a scalar, -C and l is a null vector. -C -C The coordinates are distorted, such that the event horizon is -C a coordinate sphere. -C -C Author: Erik Schnetter -C This formulation was invented by Nils Dorband -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - - subroutine Exact__Kerr_KerrSchild_spherical ( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL boostv, eps, m, a - -c local variables - CCTK_REAL t1, x1, y1, z1, rho1, - $ gamma, t0, z0, x0, y0, rho02, r02, r0, costheta0, - $ lt0, lx0, ly0, lz0, hh, lt, lx, ly, lz - - CCTK_REAL gd(3,3), gdt(3,3), det, jac(3,3) - - integer i, j, k, l - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution, -C and convert from parameter file spin parameter J/m^2 -C to the J/m definition used in the code here. - - boostv = Kerr_KerrSchild__boost_v - eps = Kerr_KerrSchild__epsilon - m = Kerr_KerrSchild__mass - a = m*Kerr_KerrSchild__spin - -C Distort the coordinates such that the event horizon is a -C coordinate sphere - rho1 = sqrt (x**2 + y**2 + z**2) - rho1 = (rho1**4 + eps**4) ** 0.25d0 - t1 = t - x1 = x - a * y / rho1 - y1 = y + a * x / rho1 - z1 = z - -C Boost factor. - - gamma = 1 / sqrt(1 - boostv**2) - -C Lorentz transform t,x,y,z -> t0,x0,y0,z0. -C t0 is never used, but is here for illustration, and we introduce -C x0 and y0 also only for clarity. -C Note that z0 = 0 means z = vt for the BH. - - t0 = gamma * ((t1 - Kerr_KerrSchild__t) - boostv * (z1 - Kerr_KerrSchild__z)) - z0 = gamma * ((z1 - Kerr_KerrSchild__z) - boostv * (t1 - Kerr_KerrSchild__t)) - x0 = x1 - Kerr_KerrSchild__x - y0 = y1 - Kerr_KerrSchild__y - -C Spherical auxiliary coordinate r and angle theta in BH rest frame. - - r0 = rho1 - costheta0 = z0 / r0 - -C Coefficient H. Note this transforms as a scalar, so does not carry -C the suffix 0. - hh = m * r0 / (r0**2 + a**2 * costheta0**2) - -C Components of l_a in rest frame. Note indices down. - lt0 = 1.d0 - lx0 = (r0 * x0 + a * y0) / (r0**2 + a**2) - ly0 = (r0 * y0 - a * x0) / (r0**2 + a**2) - lz0 = z0 / r0 - -C Now boost it to coordinates x, y, z, t. -C This is the reverse Lorentz transformation, but applied -C to a one-form, so the sign of boostv is the same as the forward -C Lorentz transformation applied to the coordinates. - - lt = gamma * (lt0 - boostv * lz0) - lz = gamma * (lz0 - boostv * lt0) - lx = lx0 - ly = ly0 - -C Down metric. g_ab = flat_ab + H l_a l_b - - gdtt = - 1.d0 + 2.d0 * hh * lt * lt - gdtx = 2.d0 * hh * lt * lx - gdty = 2.d0 * hh * lt * ly - gdtz = 2.d0 * hh * lt * lz - - gd(1,1) = 1.d0 + 2.d0 * hh * lx * lx - gd(2,2) = 1.d0 + 2.d0 * hh * ly * ly - gd(3,3) = 1.d0 + 2.d0 * hh * lz * lz - gd(1,2) = 2.d0 * hh * lx * ly - gd(2,3) = 2.d0 * hh * ly * lz - gd(3,1) = 2.d0 * hh * lz * lx - gd(2,1) = gd(1,2) - gd(3,2) = gd(2,3) - gd(1,3) = gd(3,1) - -C Transform the tensor basis back - jac(1,1) = 1 + (a*x*y) / (rho1**3) - jac(1,2) = - a * (x**2+z**2) / (rho1**3) - jac(1,3) = a*y*z / (rho1**3) - - jac(2,1) = a * (y**2+z**2) / (rho1**3) - jac(2,2) = 1 - a*x*y / (rho1**3) - jac(2,3) = - a*x*z / (rho1**3) - - jac(3,1) = 0 - jac(3,2) = 0 - jac(3,3) = 1 - - do i = 1, 3 - do j = 1, 3 - gdt(i,j) = 0 - do k = 1, 3 - do l = 1, 3 - gdt(i,j) = gdt(i,j) + gd(k,l) * jac(k,i) * jac(l,j) - end do - end do - end do - end do - - gdxx = gdt(1,1) - gdyy = gdt(2,2) - gdzz = gdt(3,3) - gdxy = gdt(1,2) - gdyz = gdt(2,3) - gdzx = gdt(3,1) - -C Up metric. g^ab = flat^ab - H l^a l^b. -C Notice that g^ab = g_ab and l^i = l_i and l^0 = - l_0 in flat spacetime. - gutt = - 1.d0 - 2.d0 * hh * lt * lt - gutx = 2.d0 * hh * lt * lx - guty = 2.d0 * hh * lt * ly - gutz = 2.d0 * hh * lt * lz - - det = gdxx*gdyy*gdzz + 2*gdxy*gdzx*gdyz - . - gdxx*gdyz**2 - gdyy*gdzx**2 - gdzz*gdxy**2 - - guxx = (gdyy*gdzz - gdyz**2)/det - guyy = (gdxx*gdzz - gdzx**2)/det - guzz = (gdxx*gdyy - gdxy**2)/det - - guxy = (gdzx*gdyz - gdzz*gdxy)/det - guyz = (gdxy*gdzx - gdxx*gdyz)/det - guzx = (gdxy*gdyz - gdyy*gdzx)/det - - end diff --git a/src/metrics/Lemaitre.F b/src/metrics/Lemaitre.F new file mode 100644 index 0000000..3318095 --- /dev/null +++ b/src/metrics/Lemaitre.F @@ -0,0 +1,88 @@ +C Lemaitre type universe - FRW with k =0, p=k rho and +C cosmological constant +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + + + subroutine Exact__Lemaitre( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL t + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL ka, la, e0, r0 + CCTK_REAL unu, ra, ra2, Pii + +c this model sets the stress-energy tensor in the "CalcTmunu" code + Tmunu_flag = .true. + + ka = Lemaitre__kappa + e0 = Lemaitre__epsilon0 + la = Lemaitre__Lambda + r0 = Lemaitre__R0 + + Pii = acos(-1.0D0) + + unu = sqrt(3.0D0*la)*t*(ka+1.0D0)/(2.0D0) + + ra = r0*(cosh(unu)+sqrt(1.0D0+8.0D0*Pii*e0/la)*sinh(unu))** + & (2.0D0/(3.0D0*ka+3.0D0)) + + ra2 = ra*ra + + gdtt = -1.0D0 + gdtx = 0.0D0 + gdty = 0.0D0 + gdtz = 0.0D0 + gdxx = ra2 + gdyy = ra2 + gdzz = ra2 + gdxy = 0.0D0 + gdyz = 0.0D0 + gdzx = 0.0D0 + + gutt = -1.0D0 + gutx = 0.0D0 + guty = 0.0D0 + gutz = 0.0D0 + guxx = 1.0D0/ra2 + guyy = 1.0D0/ra2 + guzz = 1.0D0/ra2 + guxy = 0.0D0 + guyz = 0.0D0 + guzx = 0.0D0 + + + + return + end diff --git a/src/metrics/Lemaitre.F77 b/src/metrics/Lemaitre.F77 deleted file mode 100644 index 6cfef62..0000000 --- a/src/metrics/Lemaitre.F77 +++ /dev/null @@ -1,85 +0,0 @@ -C Lemaitre type universe - FRW with k =0, p=k rho and -C cosmological constant -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - - - subroutine Exact__Lemaitre( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL ka, la, e0, r0 - CCTK_REAL unu, ra, ra2, Pii - -c this model sets the stress-energy tensor in the "CalcTmunu" code - Tmunu_flag = .true. - - ka = Lemaitre__kappa - e0 = Lemaitre__epsilon0 - la = Lemaitre__Lambda - r0 = Lemaitre__R0 - - Pii = acos(-1.0D0) - - unu = sqrt(3.0D0*la)*t*(ka+1.0D0)/(2.0D0) - - ra = r0*(cosh(unu)+sqrt(1.0D0+8.0D0*Pii*e0/la)*sinh(unu))** - & (2.0D0/(3.0D0*ka+3.0D0)) - - ra2 = ra*ra - - gdtt = -1.0D0 - gdtx = 0.0D0 - gdty = 0.0D0 - gdtz = 0.0D0 - gdxx = ra2 - gdyy = ra2 - gdzz = ra2 - gdxy = 0.0D0 - gdyz = 0.0D0 - gdzx = 0.0D0 - - gutt = -1.0D0 - gutx = 0.0D0 - guty = 0.0D0 - gutz = 0.0D0 - guxx = 1.0D0/ra2 - guyy = 1.0D0/ra2 - guzz = 1.0D0/ra2 - guxy = 0.0D0 - guyz = 0.0D0 - guzx = 0.0D0 - - - - return - end diff --git a/src/metrics/Milne.F b/src/metrics/Milne.F new file mode 100644 index 0000000..90ec9c6 --- /dev/null +++ b/src/metrics/Milne.F @@ -0,0 +1,70 @@ +C Milne spacetime metric ?!?!? +C Suggested by Matteo Rossi and E. Onofri (Univ. di Parma, Italy) +C They inted to use thsi metric for simulating an Pre-Big-Bang +C Cosmology, as proposed by Veneziano some year ago +C +C Author : D. Vulcanov (Timsoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" + + subroutine Exact__Milne( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL coef, x2,y2,z2,t2 + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + + x2= x*x + y2= y*y + z2= z*z + t2= t*t + coef= t2/(1.d0+ x2 +y2+ z2) + + gdtt = -1.d0 + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = coef*(1.d0+y2+z2) + gdyy = coef*(1.d0+x2+z2) + gdzz = coef*(1.d0+x2+y2) + gdxy = -coef*x*y + gdyz = -coef*y*z + gdzx = -coef*x*z + + gutt = -1.d0 + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = (1.d0+x2)/(t2) + guyy = (1.d0+y2)/(t2) + guzz = (1.d0+z2)/(t2) + guxy = x*y/(t2) + guyz = y*z/(t2) + guzx = x*z/(t2) + + + return + end diff --git a/src/metrics/Milne.F77 b/src/metrics/Milne.F77 deleted file mode 100644 index abd1019..0000000 --- a/src/metrics/Milne.F77 +++ /dev/null @@ -1,70 +0,0 @@ -C Milne spacetime metric ?!?!? -C Suggested by Matteo Rossi and E. Onofri (Univ. di Parma, Italy) -C They inted to use thsi metric for simulating an Pre-Big-Bang -C Cosmology, as proposed by Veneziano some year ago -C -C Author : D. Vulcanov (Timsoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" - - subroutine Exact__Milne( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL coef, x2,y2,z2,t2 - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - - x2= x*x - y2= y*y - z2= z*z - t2= t*t - coef= t2/(1.d0+ x2 +y2+ z2) - - gdtt = -1.d0 - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = coef*(1.d0+y2+z2) - gdyy = coef*(1.d0+x2+z2) - gdzz = coef*(1.d0+x2+y2) - gdxy = -coef*x*y - gdyz = -coef*y*z - gdzx = -coef*x*z - - gutt = -1.d0 - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = (1.d0+x2)/(t2) - guyy = (1.d0+y2)/(t2) - guzz = (1.d0+z2)/(t2) - guxy = x*y/(t2) - guyz = y*z/(t2) - guzx = x*z/(t2) - - - return - end diff --git a/src/metrics/Minkowski.F b/src/metrics/Minkowski.F new file mode 100644 index 0000000..f5fe4aa --- /dev/null +++ b/src/metrics/Minkowski.F @@ -0,0 +1,56 @@ +C Minkowski spacetime +C $Header$ + +#include "cctk.h" + + subroutine Exact__Minkowski( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + +c input arguments + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + + gdtt = -1.d0 + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = 1.d0 + gdyy = 1.d0 + gdzz = 1.d0 + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = -1.d0 + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = 1.d0 + guyy = 1.d0 + guzz = 1.d0 + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + return + end diff --git a/src/metrics/Minkowski.F77 b/src/metrics/Minkowski.F77 deleted file mode 100644 index ac9918c..0000000 --- a/src/metrics/Minkowski.F77 +++ /dev/null @@ -1,53 +0,0 @@ -C Minkowski spacetime -C $Header$ - -#include "cctk.h" - - subroutine Exact__Minkowski( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - - gdtt = -1.d0 - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = 1.d0 - gdyy = 1.d0 - gdzz = 1.d0 - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = -1.d0 - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = 1.d0 - guyy = 1.d0 - guzz = 1.d0 - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - return - end diff --git a/src/metrics/Minkowski_conf_wave.F b/src/metrics/Minkowski_conf_wave.F new file mode 100644 index 0000000..e2ed79a --- /dev/null +++ b/src/metrics/Minkowski_conf_wave.F @@ -0,0 +1,87 @@ +c $Header$ + +C Author: Frank Loeffler (frank.loeffler@aei.mpg.de) +C Licence: GPL 2 or later +C +C Note that this model explicitly sets the conformal factor psi , +C and thus does *NOT* work with the "arbitrary slice evolver" option +C of this thorn. + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + +#define Pi (4 * atan(1.d0)) + + + subroutine Exact__Minkowski_conf_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL x, y, z + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_REAL psi + LOGICAL Tmunu_flag + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C write conformal factor + if (Minkowski_conf_wave__direction .eq. 0) then + psi = Minkowski_conf_wave__amplitude * + . sin(2.0d0*Pi/Minkowski_conf_wave__wavelength* x ) + 1.0d0 + else if (Minkowski_conf_wave__direction .eq. 1) then + psi = Minkowski_conf_wave__amplitude * + . sin(2.0d0*Pi/Minkowski_conf_wave__wavelength* y ) + 1.0d0 + else if (Minkowski_conf_wave__direction .eq. 2) then + psi = Minkowski_conf_wave__amplitude * + . sin(2.0d0*Pi/Minkowski_conf_wave__wavelength* z ) + 1.0d0 + end if + +C write metric. + + gdxx = psi**(-4.0d0) + gdyy = gdxx + gdzz = gdxx + + gdxy = 0.0d0 + gdyz = 0.0d0 + gdzx = 0.0d0 + + gdtt = -1.0d0 + gdtx = 0.0d0 + gdty = 0.0d0 + gdtz = 0.0d0 + +C and upper metric. + + guxx = psi**4.0d0 + guyy = guxx + guzz = guxx + + guxy = 0.0d0 + guyz = 0.0d0 + guzx = 0.0d0 + + gutt = -1.0d0 + gutx = 0.0d0 + guty = 0.0d0 + gutz = 0.0d0 + + return + end diff --git a/src/metrics/Minkowski_conf_wave.F77 b/src/metrics/Minkowski_conf_wave.F77 deleted file mode 100644 index 983c6ce..0000000 --- a/src/metrics/Minkowski_conf_wave.F77 +++ /dev/null @@ -1,86 +0,0 @@ -c $Header$ - -C Author: Frank Loeffler (frank.loeffler@aei.mpg.de) -C Licence: GPL 2 or later -C -C Note that this model explicitly sets the conformal factor psi , -C and thus does *NOT* work with the "arbitrary slice evolver" option -C of this thorn. - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - -#define Pi (4 * atan(1.d0)) - - - subroutine Exact__Minkowski_conf_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C write conformal factor - if (Minkowski_conf_wave__direction .eq. 0) then - psi = Minkowski_conf_wave__amplitude * - . sin(2.0d0*Pi/Minkowski_conf_wave__wavelength* x ) + 1.0d0 - else if (Minkowski_conf_wave__direction .eq. 1) then - psi = Minkowski_conf_wave__amplitude * - . sin(2.0d0*Pi/Minkowski_conf_wave__wavelength* y ) + 1.0d0 - else if (Minkowski_conf_wave__direction .eq. 2) then - psi = Minkowski_conf_wave__amplitude * - . sin(2.0d0*Pi/Minkowski_conf_wave__wavelength* z ) + 1.0d0 - end if - -C write metric. - - gdxx = psi**(-4.0d0) - gdyy = gdxx - gdzz = gdxx - - gdxy = 0.0d0 - gdyz = 0.0d0 - gdzx = 0.0d0 - - gdtt = -1.0d0 - gdtx = 0.0d0 - gdty = 0.0d0 - gdtz = 0.0d0 - -C and upper metric. - - guxx = psi**4.0d0 - guyy = guxx - guzz = guxx - - guxy = 0.0d0 - guyz = 0.0d0 - guzx = 0.0d0 - - gutt = -1.0d0 - gutx = 0.0d0 - guty = 0.0d0 - gutz = 0.0d0 - - return - end diff --git a/src/metrics/Minkowski_funny.F b/src/metrics/Minkowski_funny.F new file mode 100644 index 0000000..48a5981 --- /dev/null +++ b/src/metrics/Minkowski_funny.F @@ -0,0 +1,114 @@ +c The metric given here corresponds to that of flat spacetime +c but with non-trivial spatial coordinates. Basically, I take +c the flat metric in spherical coordinates, define a new +c radial coordinate such that: +c +c r = r ( 1 - a f(r ) ) +c new new +c +c where f(r) is a gaussian centered at r=0 with amplitude 1. +c Finally, I transform back to cartesian coordinates. +c For 0 <= a < 1, the transformation above is monotonic. +C +C Author: unknown +C Copyright/License: unknown +C +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Minkowski_funny( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL a,s + CCTK_REAL r,r2,x2,y2,z2 + CCTK_REAL f,fp,g11,g22 + CCTK_REAL det + +c constants + CCTK_REAL zero, one, two + parameter (zero=0.0d0, one=1.0d0, two=2.0d0) + +c This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +c Read parameters + + a = Minkowski_funny__amplitude + s = Minkowski_funny__sigma + +c Find transformation function. + + x2 = x**2 + y2 = y**2 + z2 = z**2 + + r2 = x2 + y2 + z2 + r = sqrt(r2) + + f = exp(-r2/s**2) + fp = - two*r/s**2*f + +c Give metric components. + + g11 = (one - a*(f + r*fp))**2 + g22 = (one - a*f)**2 + + gdtt = - one + gdtx = zero + gdty = zero + gdtz = zero + + gdxx = (x2*g11 + (y2 + z2)*g22)/r2 + gdyy = (y2*g11 + (x2 + z2)*g22)/r2 + gdzz = (z2*g11 + (x2 + y2)*g22)/r2 + + gdxy = x*y*(g11 - g22)/r2 + gdzx = x*z*(g11 - g22)/r2 + gdyz = y*z*(g11 - g22)/r2 + +c Find inverse metric. + + gutt = - one + gutx = zero + guty = zero + gutz = zero + + det = gdxx*gdyy*gdzz + two*gdxy*gdzx*gdyz + . - gdxx*gdyz**2 - gdyy*gdzx**2 - gdzz*gdxy**2 + + guxx = (gdyy*gdzz - gdyz**2)/det + guyy = (gdxx*gdzz - gdzx**2)/det + guzz = (gdxx*gdyy - gdxy**2)/det + + guxy = (gdzx*gdyz - gdzz*gdxy)/det + guyz = (gdxy*gdzx - gdxx*gdyz)/det + guzx = (gdxy*gdyz - gdyy*gdzx)/det + + return + end diff --git a/src/metrics/Minkowski_funny.F77 b/src/metrics/Minkowski_funny.F77 deleted file mode 100644 index 7e376f3..0000000 --- a/src/metrics/Minkowski_funny.F77 +++ /dev/null @@ -1,111 +0,0 @@ -c The metric given here corresponds to that of flat spacetime -c but with non-trivial spatial coordinates. Basically, I take -c the flat metric in spherical coordinates, define a new -c radial coordinate such that: -c -c r = r ( 1 - a f(r ) ) -c new new -c -c where f(r) is a gaussian centered at r=0 with amplitude 1. -c Finally, I transform back to cartesian coordinates. -c For 0 <= a < 1, the transformation above is monotonic. -C -C Author: unknown -C Copyright/License: unknown -C -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Minkowski_funny( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x,y,z,t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL a,s - CCTK_REAL r,r2,x2,y2,z2 - CCTK_REAL f,fp,g11,g22 - CCTK_REAL det - -c constants - CCTK_REAL zero, one, two - parameter (zero=0.0d0, one=1.0d0, two=2.0d0) - -c This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -c Read parameters - - a = Minkowski_funny__amplitude - s = Minkowski_funny__sigma - -c Find transformation function. - - x2 = x**2 - y2 = y**2 - z2 = z**2 - - r2 = x2 + y2 + z2 - r = sqrt(r2) - - f = exp(-r2/s**2) - fp = - two*r/s**2*f - -c Give metric components. - - g11 = (one - a*(f + r*fp))**2 - g22 = (one - a*f)**2 - - gdtt = - one - gdtx = zero - gdty = zero - gdtz = zero - - gdxx = (x2*g11 + (y2 + z2)*g22)/r2 - gdyy = (y2*g11 + (x2 + z2)*g22)/r2 - gdzz = (z2*g11 + (x2 + y2)*g22)/r2 - - gdxy = x*y*(g11 - g22)/r2 - gdzx = x*z*(g11 - g22)/r2 - gdyz = y*z*(g11 - g22)/r2 - -c Find inverse metric. - - gutt = - one - gutx = zero - guty = zero - gutz = zero - - det = gdxx*gdyy*gdzz + two*gdxy*gdzx*gdyz - . - gdxx*gdyz**2 - gdyy*gdzx**2 - gdzz*gdxy**2 - - guxx = (gdyy*gdzz - gdyz**2)/det - guyy = (gdxx*gdzz - gdzx**2)/det - guzz = (gdxx*gdyy - gdxy**2)/det - - guxy = (gdzx*gdyz - gdzz*gdxy)/det - guyz = (gdxy*gdzx - gdxx*gdyz)/det - guzx = (gdxy*gdyz - gdyy*gdzx)/det - - return - end diff --git a/src/metrics/Minkowski_gauge_wave.F b/src/metrics/Minkowski_gauge_wave.F new file mode 100644 index 0000000..3edb3ef --- /dev/null +++ b/src/metrics/Minkowski_gauge_wave.F @@ -0,0 +1,133 @@ +C This subroutine sets up Minkowski spacetime with a gague wave. +C +c $Header$ +C +C Author: unknown +C Copyright/License: unknown +C + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + +#define Pi (4 * atan(1.d0)) + + + subroutine Exact__Minkowski_gauge_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL x, y, t + CCTK_DECLARE(CCTK_REAL, z,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local parameter copies + CCTK_REAL a, o, d, fs + +c local variables + CCTK_REAL H + character*100 warn_buffer + +c constants + CCTK_REAL zero,half,one + parameter (zero = 0.0d0, half=0.5d0, one=1.0d0) + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution. + a = Minkowski_gauge_wave__amplitude + o = Minkowski_gauge_wave__omega + d = Minkowski_gauge_wave__lambda + fs = Minkowski_gauge_wave__phase + +C How should the wave look like. + if (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"sin")) then + d = Minkowski_gauge_wave__lambda * half / Pi + if (Minkowski_gauge_wave__diagonal.ne.0) then + H = one - a * sin((x-y)/d - o*t/d - fs) + else + H = one - a * sin((x-o*t)/d - fs) + end if + elseif (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"expsin")) then +c$$$ d = Minkowski_gauge_wave__lambda * half / Pi +c$$$ H = exp(a*sin(x/d)*cos(t/d)) + d = Minkowski_gauge_wave__lambda * half / Pi + if (Minkowski_gauge_wave__diagonal.ne.0) then + H = exp(- a * sin((x-y)/d - o*t/d - fs)) + else + H = exp(- a * sin((x-o*t)/d - fs)) + end if + elseif (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"Gaussian")) then + H = one - a*exp(-(x-t)**2/d**2) + else + write (warn_buffer, '(a,a,a)') + $ 'Unknown Minkowski_gauge_wave__what_fn = "', + $ Minkowski_gauge_wave__what_fn, '"' +C silence compiler warning about uninitialized H + H = one + call CCTK_WARN(0, warn_buffer) + end if + +C write metric. + + if (Minkowski_gauge_wave__diagonal.ne.0) then + + gdxx = half * H + half + gdxy = -half * H + half + gdyy = half * H + half + + guxx = half / H + half + guxy = -half / H + half + guyy = half / H + half + + else + + gdxx = H + gdxy = zero + gdyy = one + + guxx = one/H + guxy = zero + guyy = one + + end if + + gdtt = -H + gdtx = zero + gdty = zero + gdtz = zero + + gdzx = zero + gdyz = zero + gdzz = one + +C and upper metric. + + gutt = -one / H + gutx = zero + guty = zero + gutz = zero + + guyz = zero + guzx = zero + guzz = one + + return + end diff --git a/src/metrics/Minkowski_gauge_wave.F77 b/src/metrics/Minkowski_gauge_wave.F77 deleted file mode 100644 index 639b0a7..0000000 --- a/src/metrics/Minkowski_gauge_wave.F77 +++ /dev/null @@ -1,130 +0,0 @@ -C This subroutine sets up Minkowski spacetime with a gague wave. -C -c $Header$ -C -C Author: unknown -C Copyright/License: unknown -C - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - -#define Pi (4 * atan(1.d0)) - - - subroutine Exact__Minkowski_gauge_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local parameter copies - CCTK_REAL a, o, d, fs - -c local variables - CCTK_REAL H - character*100 warn_buffer - -c constants - CCTK_REAL zero,half,one - parameter (zero = 0.0d0, half=0.5d0, one=1.0d0) - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution. - a = Minkowski_gauge_wave__amplitude - o = Minkowski_gauge_wave__omega - d = Minkowski_gauge_wave__lambda - fs = Minkowski_gauge_wave__phase - -C How should the wave look like. - if (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"sin")) then - d = Minkowski_gauge_wave__lambda * half / Pi - if (Minkowski_gauge_wave__diagonal.ne.0) then - H = one - a * sin((x-y)/d - o*t/d - fs) - else - H = one - a * sin((x-o*t)/d - fs) - end if - elseif (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"expsin")) then -c$$$ d = Minkowski_gauge_wave__lambda * half / Pi -c$$$ H = exp(a*sin(x/d)*cos(t/d)) - d = Minkowski_gauge_wave__lambda * half / Pi - if (Minkowski_gauge_wave__diagonal.ne.0) then - H = exp(- a * sin((x-y)/d - o*t/d - fs)) - else - H = exp(- a * sin((x-o*t)/d - fs)) - end if - elseif (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"Gaussian")) then - H = one - a*exp(-(x-t)**2/d**2) - else - write (warn_buffer, '(a,a,a)') - $ 'Unknown Minkowski_gauge_wave__what_fn = "', - $ Minkowski_gauge_wave__what_fn, '"' - call CCTK_WARN(0, warn_buffer) - end if - -C write metric. - - if (Minkowski_gauge_wave__diagonal.ne.0) then - - gdxx = half * H + half - gdxy = -half * H + half - gdyy = half * H + half - - guxx = half / H + half - guxy = -half / H + half - guyy = half / H + half - - else - - gdxx = H - gdxy = zero - gdyy = one - - guxx = one/H - guxy = zero - guyy = one - - end if - - gdtt = -H - gdtx = zero - gdty = zero - gdtz = zero - - gdzx = zero - gdyz = zero - gdzz = one - -C and upper metric. - - gutt = -one / H - gutx = zero - guty = zero - gutz = zero - - guyz = zero - guzx = zero - guzz = one - - return - end diff --git a/src/metrics/Minkowski_shift.F b/src/metrics/Minkowski_shift.F new file mode 100644 index 0000000..3115a75 --- /dev/null +++ b/src/metrics/Minkowski_shift.F @@ -0,0 +1,112 @@ +c The metric given here corresponds to that of flat spacetime +c but with non-trivial slicing and a shift vector such that +c the resulting metric is still time independent. I take +c the flat metric in spherical coordinates and define a new +c time coordinate as: +c +c t = t - a f(r) +c new +c +c where f(r) is a gaussian centered at r=0 with amplitude 1. +c Finally, I transform back to cartesian coordinates. +c For -1 < fp < 1, the transformation above results in spatial +c slices. +C +C Author: unknown +C Copyright/License: unknown +C +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Minkowski_shift( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x,y,z + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL a,s + CCTK_REAL r,r2,x2,y2,z2 + CCTK_REAL f,fp,fpr,fpr2 + +c constants + CCTK_REAL zero,one,two + parameter (zero=0.0d0, one=1.0d0, two=2.0d0) + +c This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +c Read parameters + + a = Minkowski_shift__amplitude + s = Minkowski_shift__sigma + +c Find transformation function. + + x2 = x**2 + y2 = y**2 + z2 = z**2 + + r2 = x2 + y2 + z2 + r = sqrt(r2) + + f = a*exp(-r2/s**2) + fp = - two*f*r/s**2 + fpr = fp/r + fpr2 = fpr**2 + +c Give metric components. + + gdtt = - one + + gdtx = - x*fpr + gdty = - y*fpr + gdtz = - z*fpr + + gdxx = one - x2*fpr2 + gdyy = one - y2*fpr2 + gdzz = one - z2*fpr2 + + gdxy = - x*y*fpr2 + gdzx = - x*z*fpr2 + gdyz = - y*z*fpr2 + +c Inverse metric. And yes, it is this simple, simpler +c than the metric itself. I tripled checked! + + gutt = - one + fp**2 + + gutx = - x*fpr + guty = - y*fpr + gutz = - z*fpr + + guxx = one + guyy = one + guzz = one + + guxy = zero + guzx = zero + guyz = zero + + return + end diff --git a/src/metrics/Minkowski_shift.F77 b/src/metrics/Minkowski_shift.F77 deleted file mode 100644 index 394bf67..0000000 --- a/src/metrics/Minkowski_shift.F77 +++ /dev/null @@ -1,111 +0,0 @@ -c The metric given here corresponds to that of flat spacetime -c but with non-trivial slicing and a shift vector such that -c the resulting metric is still time independent. I take -c the flat metric in spherical coordinates and define a new -c time coordinate as: -c -c t = t - a f(r) -c new -c -c where f(r) is a gaussian centered at r=0 with amplitude 1. -c Finally, I transform back to cartesian coordinates. -c For -1 < fp < 1, the transformation above results in spatial -c slices. -C -C Author: unknown -C Copyright/License: unknown -C -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Minkowski_shift( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x,y,z,t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL a,s - CCTK_REAL r,r2,x2,y2,z2 - CCTK_REAL f,fp,fpr,fpr2 - -c constants - CCTK_REAL zero,one,two - parameter (zero=0.0d0, one=1.0d0, two=2.0d0) - -c This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -c Read parameters - - a = Minkowski_shift__amplitude - s = Minkowski_shift__sigma - -c Find transformation function. - - x2 = x**2 - y2 = y**2 - z2 = z**2 - - r2 = x2 + y2 + z2 - r = sqrt(r2) - - f = a*exp(-r2/s**2) - fp = - two*f*r/s**2 - fpr = fp/r - fpr2 = fpr**2 - -c Give metric components. - - gdtt = - one - - gdtx = - x*fpr - gdty = - y*fpr - gdtz = - z*fpr - - gdxx = one - x2*fpr2 - gdyy = one - y2*fpr2 - gdzz = one - z2*fpr2 - - gdxy = - x*y*fpr2 - gdzx = - x*z*fpr2 - gdyz = - y*z*fpr2 - -c Inverse metric. And yes, it is this simple, simpler -c than the metric itself. I tripled checked! - - gutt = - one + fp**2 - - gutx = - x*fpr - guty = - y*fpr - gutz = - z*fpr - - guxx = one - guyy = one - guzz = one - - guxy = zero - guzx = zero - guyz = zero - - return - end diff --git a/src/metrics/Minkowski_shifted_gauge_wave.F b/src/metrics/Minkowski_shifted_gauge_wave.F new file mode 100644 index 0000000..68caf89 --- /dev/null +++ b/src/metrics/Minkowski_shifted_gauge_wave.F @@ -0,0 +1,121 @@ +C This subroutine sets up Minkowski spacetime with a gague wave. +C +c $Header$ +C +C Author: unknown +C Copyright/License: unknown +C + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + +#define Pi (4 * atan(1.d0)) + + + subroutine Exact__Minkowski_shifted_gauge_wave( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL x, y, t + CCTK_DECLARE(CCTK_REAL, z,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local parameter copies + CCTK_REAL a, o, d, fs + +c local variables + CCTK_REAL H + character*100 warn_buffer + +c constants + CCTK_REAL zero,half,one + parameter (zero = 0.0d0, half=0.5d0, one=1.0d0) + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution. + a = Minkowski_gauge_wave__amplitude + o = Minkowski_gauge_wave__omega + d = Minkowski_gauge_wave__lambda + fs = Minkowski_gauge_wave__phase + +C How should the wave look like. + if (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"sin")) then + d = Minkowski_gauge_wave__lambda * half / Pi + if (Minkowski_gauge_wave__diagonal.ne.0) then + H = a * sin((x-y)/d - o*t/d - fs) + else + H = a * sin((x-o*t)/d - fs) + end if + else + write (warn_buffer, '(a,a,a)') + $ 'Unknown Minkowski_gauge_wave__what_fn = "', + $ Minkowski_gauge_wave__what_fn, '"' +C silence compiler warning about unused variable + H = one + call CCTK_WARN(0, warn_buffer) + end if + +C write metric. + + if (Minkowski_gauge_wave__diagonal.ne.0) then + + gdxx = half * H + one + gdxy = - half * H + gdyy = half * H + one + + guxx = - half * H + one + guxy = half * H + guyy = - half * H + one + + else + + gdxx = H + one + gdxy = zero + gdyy = one + + guxx = - H + one + guxy = zero + guyy = one + + end if + + gdtt = H - one + gdtx = - H + gdty = zero + gdtz = zero + + gdzx = zero + gdyz = zero + gdzz = one + +C and upper metric. + + gutt = - H - one + gutx = - H + guty = zero + gutz = zero + + guyz = zero + guzx = zero + guzz = one + + end diff --git a/src/metrics/Minkowski_shifted_gauge_wave.F77 b/src/metrics/Minkowski_shifted_gauge_wave.F77 deleted file mode 100644 index 2806a58..0000000 --- a/src/metrics/Minkowski_shifted_gauge_wave.F77 +++ /dev/null @@ -1,118 +0,0 @@ -C This subroutine sets up Minkowski spacetime with a gague wave. -C -c $Header$ -C -C Author: unknown -C Copyright/License: unknown -C - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - -#define Pi (4 * atan(1.d0)) - - - subroutine Exact__Minkowski_shifted_gauge_wave( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local parameter copies - CCTK_REAL a, o, d, fs - -c local variables - CCTK_REAL H - character*100 warn_buffer - -c constants - CCTK_REAL zero,half,one - parameter (zero = 0.0d0, half=0.5d0, one=1.0d0) - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution. - a = Minkowski_gauge_wave__amplitude - o = Minkowski_gauge_wave__omega - d = Minkowski_gauge_wave__lambda - fs = Minkowski_gauge_wave__phase - -C How should the wave look like. - if (CCTK_EQUALS(Minkowski_gauge_wave__what_fn,"sin")) then - d = Minkowski_gauge_wave__lambda * half / Pi - if (Minkowski_gauge_wave__diagonal.ne.0) then - H = a * sin((x-y)/d - o*t/d - fs) - else - H = a * sin((x-o*t)/d - fs) - end if - else - write (warn_buffer, '(a,a,a)') - $ 'Unknown Minkowski_gauge_wave__what_fn = "', - $ Minkowski_gauge_wave__what_fn, '"' - call CCTK_WARN(0, warn_buffer) - end if - -C write metric. - - if (Minkowski_gauge_wave__diagonal.ne.0) then - - gdxx = half * H + one - gdxy = - half * H - gdyy = half * H + one - - guxx = - half * H + one - guxy = half * H - guyy = - half * H + one - - else - - gdxx = H + one - gdxy = zero - gdyy = one - - guxx = - H + one - guxy = zero - guyy = one - - end if - - gdtt = H - one - gdtx = - H - gdty = zero - gdtz = zero - - gdzx = zero - gdyz = zero - gdzz = one - -C and upper metric. - - gutt = - H - one - gutx = - H - guty = zero - gutz = zero - - guyz = zero - guzx = zero - guzz = one - - end diff --git a/src/metrics/Schwarzschild_BL.F b/src/metrics/Schwarzschild_BL.F new file mode 100644 index 0000000..ed6e220 --- /dev/null +++ b/src/metrics/Schwarzschild_BL.F @@ -0,0 +1,72 @@ +c Schwarzschild spacetime in Brill-Lindquist coordinates. +C +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Schwarzschild_BL( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL eps, m + +c local variables + CCTK_REAL r, psi4 + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution. + + eps = Schwarzschild_BL__epsilon + m = Schwarzschild_BL__mass + + r = ((x**2 + y**2 + z**2)**2 + eps**4) ** 0.25d0 + psi4 = (1 + m / (2 * r)) ** 4 + + gdtt = -1 + gdtx = 0 + gdty = 0 + gdtz = 0 + gdxx = psi4 + gdyy = psi4 + gdzz = psi4 + gdxy = 0 + gdyz = 0 + gdzx = 0 + + gutt = -1 + gutx = 0 + guty = 0 + gutz = 0 + guxx = 1 / psi4 + guyy = 1 / psi4 + guzz = 1 / psi4 + guxy = 0 + guyz = 0 + guzx = 0 + + return + end diff --git a/src/metrics/Schwarzschild_BL.F77 b/src/metrics/Schwarzschild_BL.F77 deleted file mode 100644 index f9d63f7..0000000 --- a/src/metrics/Schwarzschild_BL.F77 +++ /dev/null @@ -1,71 +0,0 @@ -c Schwarzschild spacetime in Brill-Lindquist coordinates. -C -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Schwarzschild_BL( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL eps, m - -c local variables - CCTK_REAL r, psi4 - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution. - - eps = Schwarzschild_BL__epsilon - m = Schwarzschild_BL__mass - - r = ((x**2 + y**2 + z**2)**2 + eps**4) ** 0.25d0 - psi4 = (1 + m / (2 * r)) ** 4 - - gdtt = -1 - gdtx = 0 - gdty = 0 - gdtz = 0 - gdxx = psi4 - gdyy = psi4 - gdzz = psi4 - gdxy = 0 - gdyz = 0 - gdzx = 0 - - gutt = -1 - gutx = 0 - guty = 0 - gutz = 0 - guxx = 1 / psi4 - guyy = 1 / psi4 - guzz = 1 / psi4 - guxy = 0 - guyz = 0 - guzx = 0 - - return - end diff --git a/src/metrics/Schwarzschild_EF.F b/src/metrics/Schwarzschild_EF.F new file mode 100644 index 0000000..bed3fad --- /dev/null +++ b/src/metrics/Schwarzschild_EF.F @@ -0,0 +1,75 @@ +c Schwarzschild metric in Eddington-Finkelstein coordinates, +c as per MTW box 31.2 +C +C Author: unknown +C Copyright/License: unknown +C +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Schwarzschild_EF( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local static variables + CCTK_REAL eps, m + +c local variables + CCTK_REAL r + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution. + + eps = Schwarzschild_EF__epsilon + m = Schwarzschild_EF__mass + + r = max(sqrt(x**2 + y**2 + z**2), eps) + + gdtt = - (1.d0 - 2.d0 * m / r) + gdtx = 2.d0 * m * x / r**2 + gdty = 2.d0 * m * y / r**2 + gdtz = 2.d0 * m * z / r**2 + gdxx = 1.d0 + 2.d0 * m * x**2 / r**3 + gdyy = 1.d0 + 2.d0 * m * y**2 / r**3 + gdzz = 1.d0 + 2.d0 * m * z**2 / r**3 + gdxy = 2.d0 * m * x * y / r**3 + gdyz = 2.d0 * m * y * z / r**3 + gdzx = 2.d0 * m * z * x / r**3 + + gutt = - (1.d0 + 2.d0 * m / r) + gutx = 2.d0 * m * x / r**2 + guty = 2.d0 * m * y / r**2 + gutz = 2.d0 * m * z / r**2 + guxx = 1.d0 - 2.d0 * m * x**2 / r**3 + guyy = 1.d0 - 2.d0 * m * y**2 / r**3 + guzz = 1.d0 - 2.d0 * m * z**2 / r**3 + guxy = - 2.d0 * m * x * y / r**3 + guyz = - 2.d0 * m * y * z / r**3 + guzx = - 2.d0 * m * z * x / r**3 + + return + end diff --git a/src/metrics/Schwarzschild_EF.F77 b/src/metrics/Schwarzschild_EF.F77 deleted file mode 100644 index 66a9db4..0000000 --- a/src/metrics/Schwarzschild_EF.F77 +++ /dev/null @@ -1,74 +0,0 @@ -c Schwarzschild metric in Eddington-Finkelstein coordinates, -c as per MTW box 31.2 -C -C Author: unknown -C Copyright/License: unknown -C -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Schwarzschild_EF( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local static variables - CCTK_REAL eps, m - -c local variables - CCTK_REAL r - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution. - - eps = Schwarzschild_EF__epsilon - m = Schwarzschild_EF__mass - - r = max(sqrt(x**2 + y**2 + z**2), eps) - - gdtt = - (1.d0 - 2.d0 * m / r) - gdtx = 2.d0 * m * x / r**2 - gdty = 2.d0 * m * y / r**2 - gdtz = 2.d0 * m * z / r**2 - gdxx = 1.d0 + 2.d0 * m * x**2 / r**3 - gdyy = 1.d0 + 2.d0 * m * y**2 / r**3 - gdzz = 1.d0 + 2.d0 * m * z**2 / r**3 - gdxy = 2.d0 * m * x * y / r**3 - gdyz = 2.d0 * m * y * z / r**3 - gdzx = 2.d0 * m * z * x / r**3 - - gutt = - (1.d0 + 2.d0 * m / r) - gutx = 2.d0 * m * x / r**2 - guty = 2.d0 * m * y / r**2 - gutz = 2.d0 * m * z / r**2 - guxx = 1.d0 - 2.d0 * m * x**2 / r**3 - guyy = 1.d0 - 2.d0 * m * y**2 / r**3 - guzz = 1.d0 - 2.d0 * m * z**2 / r**3 - guxy = - 2.d0 * m * x * y / r**3 - guyz = - 2.d0 * m * y * z / r**3 - guzx = - 2.d0 * m * z * x / r**3 - - return - end diff --git a/src/metrics/Schwarzschild_Lemaitre.F b/src/metrics/Schwarzschild_Lemaitre.F new file mode 100644 index 0000000..aff86a9 --- /dev/null +++ b/src/metrics/Schwarzschild_Lemaitre.F @@ -0,0 +1,80 @@ +C Schwarzschild-Lemaitre metric +c (Schwarzschild black hole with cosmological constant) +C Proposed by Lemaitre in 1932 +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Schwarzschild_Lemaitre( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL lam, mas + CCTK_REAL r2, ppp, unu, doi + +C This model has a cosmological constant + Tmunu_flag = .true. + + lam = Schwarzschild_Lemaitre__Lambda + mas = Schwarzschild_Lemaitre__mass + + r2 =x*x+y*y+z*z + + ppp=1.0D0 -2.0D0*mas/sqrt(r2) -r2*lam/3.0D0 + + unu=(1.0D0-ppp)/ppp/r2 + + doi=(ppp - 1.0D0)/r2 + + gdtt = -ppp + gdtx = 0.0D0 + gdty = 0.0D0 + gdtz = 0.0D0 + gdxx = 1.0D0 + x*x*unu + gdyy = 1.0D0 + y*y*unu + gdzz = 1.0D0 + z*z*unu + gdxy = x*y*unu + gdyz = y*z*unu + gdzx = z*x*unu + + + gutt = -1.0D0/ppp + gutx = 0.0D0 + guty = 0.0D0 + gutz = 0.0D0 + guxx = 1.0D0 + x*x*doi + guyy = 1.0D0 + y*y*doi + guzz = 1.0D0 + z*z*doi + guxy = x*y*doi + guyz = y*z*doi + guzx = x*z*doi + + + return + end diff --git a/src/metrics/Schwarzschild_Lemaitre.F77 b/src/metrics/Schwarzschild_Lemaitre.F77 deleted file mode 100644 index b5a2dc7..0000000 --- a/src/metrics/Schwarzschild_Lemaitre.F77 +++ /dev/null @@ -1,79 +0,0 @@ -C Schwarzschild-Lemaitre metric -c (Schwarzschild black hole with cosmological constant) -C Proposed by Lemaitre in 1932 -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Schwarzschild_Lemaitre( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL lam, mas - CCTK_REAL r2, ppp, unu, doi - -C This model has a cosmological constant - Tmunu_flag = .true. - - lam = Schwarzschild_Lemaitre__Lambda - mas = Schwarzschild_Lemaitre__mass - - r2 =x*x+y*y+z*z - - ppp=1.0D0 -2.0D0*mas/sqrt(r2) -r2*lam/3.0D0 - - unu=(1.0D0-ppp)/ppp/r2 - - doi=(ppp - 1.0D0)/r2 - - gdtt = -ppp - gdtx = 0.0D0 - gdty = 0.0D0 - gdtz = 0.0D0 - gdxx = 1.0D0 + x*x*unu - gdyy = 1.0D0 + y*y*unu - gdzz = 1.0D0 + z*z*unu - gdxy = x*y*unu - gdyz = y*z*unu - gdzx = z*x*unu - - - gutt = -1.0D0/ppp - gutx = 0.0D0 - guty = 0.0D0 - gutz = 0.0D0 - guxx = 1.0D0 + x*x*doi - guyy = 1.0D0 + y*y*doi - guzz = 1.0D0 + z*z*doi - guxy = x*y*doi - guyz = y*z*doi - guzx = x*z*doi - - - return - end diff --git a/src/metrics/Schwarzschild_Novikov.F b/src/metrics/Schwarzschild_Novikov.F new file mode 100644 index 0000000..4b3109c --- /dev/null +++ b/src/metrics/Schwarzschild_Novikov.F @@ -0,0 +1,207 @@ +c The metric given here corresponds to the novikov solution +c in isotropic coordinates, as presented first in Bruegman96 +c then in correct form in Cactus paper 1. This code is the code +c which was used for the comparisons in cactus paper 1, and is written +c by PW with input from BB. +C +C Author: unknown +C Copyright/License: unknown +C +C $Header$ + + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Schwarzschild_Novikov( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL eps, mass + CCTK_REAL r,c,psi4 + + CCTK_REAL nov_dr_drmax, nov_rmax, nov_r + CCTK_REAL grr, gqq, detg + + CCTK_REAL psi4_o_r2 + +c constants + CCTK_REAL zero,one,two + parameter (zero=0.0d0, one=1.0d0, two=2.0d0) + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution. + + eps = Schwarzschild_Novikov__epsilon + mass= Schwarzschild_Novikov__mass + + r = max(sqrt(x**2 + y**2 + z**2), eps) + +c Find r. + r = sqrt(x**2 + y**2 + z**2) + +c Find conformal factor. + c = mass/(two*r) + psi4 = (one + c)**4 + +c Evaluate novikov stuff. Note abs(t) since the data is time +c symmetric (the metric is, at least...) + grr = nov_dr_drmax(abs(t),abs(r)) + gqq = nov_r(abs(t),abs(r)) + + grr = grr **2 + gqq = gqq**2 / nov_rmax(abs(r))**2 + + +c Find metric components. + psi4_o_r2 = psi4 / r**2 + + gdtt = - 1.0D0 + + gdtx = zero + gdty = zero + gdtz = zero + +c This is just straightforward spherical -> cartesian I hope... ;-) +c Note at t=0 (grr = gqq = 1) this gives the expected result +c (namely diagonal psi^4, since psi4_o_r2 = psi^4 / r^2) + gdxx = (grr * x**2 + gqq * (y**2 + z**2)) * psi4_o_r2 + gdyy = (grr * y**2 + gqq * (x**2 + z**2)) * psi4_o_r2 + gdzz = (grr * z**2 + gqq * (x**2 + y**2)) * psi4_o_r2 + + gdxy = (grr - gqq) * x * y * psi4_o_r2 + gdzx = (grr - gqq) * x * z * psi4_o_r2 + gdyz = (grr - gqq) * y * z * psi4_o_r2 + +c Find inverse metric. + gutt = one/gdtt + gutx = zero + guty = zero + gutz = zero + detg = gdtt*gdxx*gdyy*gdzz-gdtt*gdxx*gdyz**2/4.D0-gdtt*gdxy**2*gdz + $z/4.D0+gdtt*gdxy*gdzx*gdyz/4.D0-gdtt*gdzx**2*gdyy/4.D0 + guxx = -gdtt*(-4.D0*gdyy*gdzz+gdyz**2)/(4.D0 * detg) + guxy = -gdtt*(2.D0*gdxy*gdzz-gdzx*gdyz)/(4.D0 * detg) + guzx = gdtt*(gdxy*gdyz-2.D0*gdzx*gdyy)/(4.D0 * detg) + guyy = gdtt*(4.D0*gdxx*gdzz-gdzx**2)/(4.D0 * detg) + guyz = -gdtt*(2.D0*gdxx*gdyz-gdxy*gdzx)/(4.D0 * detg) + guzz = gdtt*(4.D0*gdxx*gdyy-gdxy**2)/(4.D0 * detg) + + guxx = one/psi4 + guyy = one/psi4 + guzz = one/psi4 + + guxy = zero + guyz = zero + guzx = zero + + return + end + +c These are functions which evaluate the novikov stuff. + +c dr/drmax + CCTK_REAL function nov_dr_drmax(tauin,rbarin) + + implicit none + + CCTK_REAL rbarin, tauin + CCTK_REAL rt, nov_r, rmaxt, nov_rmax + + rt = nov_r(tauin, rbarin) + rmaxt = nov_rmax(rbarin) + nov_dr_drmax = 1.5D0 - rt / (2.0D0 * rmaxt) + + $ 1.5D0 * sqrt(rmaxt / rt - 1.0D0) * + $ acos(sqrt(rt/rmaxt)) + + return + end + + + +c +c Bisection to invert the function below. This is pretty crappy +c but it works. +c + CCTK_REAL function nov_r(tauin, rbarin) + implicit none +c input + CCTK_REAL tauin, rbarin + +c funtions + CCTK_REAL nov_rmax, nov_tau + +c temps + CCTK_REAL rg, drg, delt, ttmp, rmt + CCTK_REAL eps + integer nit + nit = 0 + delt = 1000.0D0 + rmt = nov_rmax(rbarin) + rg = rmt + drg = rg / 2.0D0 + eps = 1.d-6 * rmt + do while (delt .gt. eps .and. nit .lt. 100) + ttmp = nov_tau(rg, rmt) + delt = abs(tauin - ttmp) + if (delt .gt. eps) then + if (ttmp .gt. tauin .or. rg .lt. drg) then + rg = rg + drg +c Enforce upper bound + if (rg .gt. rmt) rg = rmt + drg = drg / 2.0D0 + else + rg = rg - drg + endif + endif +c write (*,*) rg, ttmp, tauin + nit = nit + 1 + enddo + if (nit .ge. 100) then + write (*,*) "Novikov: inversion did not converge" + endif + nov_r = rg + return + end + +c Evaluate tau as a function of r and rmax + CCTK_REAL function nov_tau(r, rmax) + implicit none + CCTK_REAL r, rmax + + nov_tau= rmax * sqrt(0.5D0 * r * (1.0D0 - r / rmax)) + + $ 2.0D0 * (rmax / 2)**(3.0/2.0) * + $ acos (sqrt(r/rmax)) + + return + end + +c Evaluate rmax as a function of rbar + CCTK_REAL function nov_rmax(rbar) + implicit none + CCTK_REAL rbar + nov_rmax = (1.0D0 + 2.0D0*rbar)**2 / (4.0D0 * rbar) + return + end diff --git a/src/metrics/Schwarzschild_Novikov.F77 b/src/metrics/Schwarzschild_Novikov.F77 deleted file mode 100644 index 2f797d2..0000000 --- a/src/metrics/Schwarzschild_Novikov.F77 +++ /dev/null @@ -1,207 +0,0 @@ -c The metric given here corresponds to the novikov solution -c in isotropic coordinates, as presented first in Bruegman96 -c then in correct form in Cactus paper 1. This code is the code -c which was used for the comparisons in cactus paper 1, and is written -c by PW with input from BB. -C -C Author: unknown -C Copyright/License: unknown -C -C $Header$ - - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Schwarzschild_Novikov( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL eps, mass - CCTK_REAL r,c,psi4 - - CCTK_REAL nov_dr_drmax, nov_rmax, nov_r - CCTK_REAL grr, gqq, detg - - CCTK_REAL psi4_o_r2 - -c constants - CCTK_REAL zero,one,two - parameter (zero=0.0d0, one=1.0d0, two=2.0d0) - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution. - - eps = Schwarzschild_Novikov__epsilon - mass= Schwarzschild_Novikov__mass - - r = max(sqrt(x**2 + y**2 + z**2), eps) - -c Find r. - r = sqrt(x**2 + y**2 + z**2) - -c Find conformal factor. - c = mass/(two*r) - psi4 = (one + c)**4 - -c Evaluate novikov stuff. Note abs(t) since the data is time -c symmetric (the metric is, at least...) - grr = nov_dr_drmax(abs(t),abs(r)) - gqq = nov_r(abs(t),abs(r)) - - grr = grr **2 - gqq = gqq**2 / nov_rmax(abs(r))**2 - - -c Find metric components. - psi4_o_r2 = psi4 / r**2 - - gdtt = - 1.0D0 - - gdtx = zero - gdty = zero - gdtz = zero - -c This is just straightforward spherical -> cartesian I hope... ;-) -c Note at t=0 (grr = gqq = 1) this gives the expected result -c (namely diagonal psi^4, since psi4_o_r2 = psi^4 / r^2) - gdxx = (grr * x**2 + gqq * (y**2 + z**2)) * psi4_o_r2 - gdyy = (grr * y**2 + gqq * (x**2 + z**2)) * psi4_o_r2 - gdzz = (grr * z**2 + gqq * (x**2 + y**2)) * psi4_o_r2 - - gdxy = (grr - gqq) * x * y * psi4_o_r2 - gdzx = (grr - gqq) * x * z * psi4_o_r2 - gdyz = (grr - gqq) * y * z * psi4_o_r2 - -c Find inverse metric. - gutt = one/gdtt - gutx = zero - guty = zero - gutz = zero - detg = gdtt*gdxx*gdyy*gdzz-gdtt*gdxx*gdyz**2/4.D0-gdtt*gdxy**2*gdz - $z/4.D0+gdtt*gdxy*gdzx*gdyz/4.D0-gdtt*gdzx**2*gdyy/4.D0 - guxx = -gdtt*(-4.D0*gdyy*gdzz+gdyz**2)/(4.D0 * detg) - guxy = -gdtt*(2.D0*gdxy*gdzz-gdzx*gdyz)/(4.D0 * detg) - guzx = gdtt*(gdxy*gdyz-2.D0*gdzx*gdyy)/(4.D0 * detg) - guyy = gdtt*(4.D0*gdxx*gdzz-gdzx**2)/(4.D0 * detg) - guyz = -gdtt*(2.D0*gdxx*gdyz-gdxy*gdzx)/(4.D0 * detg) - guzz = gdtt*(4.D0*gdxx*gdyy-gdxy**2)/(4.D0 * detg) - - guxx = one/psi4 - guyy = one/psi4 - guzz = one/psi4 - - guxy = zero - guyz = zero - guzx = zero - - return - end - -c These are functions which evaluate the novikov stuff. - -c dr/drmax - CCTK_REAL function nov_dr_drmax(tauin,rbarin) - - implicit none - - CCTK_REAL rbarin, tauin - CCTK_REAL rt, nov_r, rmaxt, nov_rmax - - rt = nov_r(tauin, rbarin) - rmaxt = nov_rmax(rbarin) - nov_dr_drmax = 1.5D0 - rt / (2.0D0 * rmaxt) + - $ 1.5D0 * sqrt(rmaxt / rt - 1.0D0) * - $ acos(sqrt(rt/rmaxt)) - - return - end - - - -c -c Bisection to invert the function below. This is pretty crappy -c but it works. -c - CCTK_REAL function nov_r(tauin, rbarin) - implicit none -c input - CCTK_REAL tauin, rbarin - -c funtions - CCTK_REAL nov_rmax, nov_tau - -c temps - CCTK_REAL rg, drg, delt, ttmp, rmt - CCTK_REAL eps - integer nit - nit = 0 - delt = 1000.0D0 - rmt = nov_rmax(rbarin) - rg = rmt - drg = rg / 2.0D0 - eps = 1.d-6 * rmt - do while (delt .gt. eps .and. nit .lt. 100) - ttmp = nov_tau(rg, rmt) - delt = abs(tauin - ttmp) - if (delt .gt. eps) then - if (ttmp .gt. tauin .or. rg .lt. drg) then - rg = rg + drg -c Enforce upper bound - if (rg .gt. rmt) rg = rmt - drg = drg / 2.0D0 - else - rg = rg - drg - endif - endif -c write (*,*) rg, ttmp, tauin - nit = nit + 1 - enddo - if (nit .ge. 100) then - write (*,*) "Novikov: inversion did not converge" - endif - nov_r = rg - return - end - -c Evaluate tau as a function of r and rmax - CCTK_REAL function nov_tau(r, rmax) - implicit none - CCTK_REAL r, rmax - - nov_tau= rmax * sqrt(0.5D0 * r * (1.0D0 - r / rmax)) + - $ 2.0D0 * (rmax / 2)**(3.0/2.0) * - $ acos (sqrt(r/rmax)) - - return - end - -c Evaluate rmax as a function of rbar - CCTK_REAL function nov_rmax(rbar) - implicit none - CCTK_REAL rbar - nov_rmax = (1.0D0 + 2.0D0*rbar)**2 / (4.0D0 * rbar) - return - end diff --git a/src/metrics/Schwarzschild_PG.F b/src/metrics/Schwarzschild_PG.F new file mode 100644 index 0000000..e0ba3c2 --- /dev/null +++ b/src/metrics/Schwarzschild_PG.F @@ -0,0 +1,78 @@ +c Schwarzschild spacetime in Painleve [e-acute on last e]-Gullstrand +c coordinates. These have a *flat* 3-metric, and are described in +c detail in Martel and Poisson, gr-qc/0001069 +C +C Author: unknown +C Copyright/License: unknown +C +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__Schwarzschild_PG( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL eps, m + CCTK_REAL r, bx, by, bz, b2 + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution. + + eps = Schwarzschild_PG__epsilon + m = Schwarzschild_PG__mass + + r = max(sqrt(x**2 + y**2 + z**2), eps) + bx = sqrt(2.d0 * m / r) * x / r + by = sqrt(2.d0 * m / r) * y / r + bz = sqrt(2.d0 * m / r) * z / r + b2 = 2.d0 * m / r + + gdtt = - 1.d0 + b2 + gdtx = bx + gdty = by + gdtz = bz + gdxx = 1.d0 + gdyy = 1.d0 + gdzz = 1.d0 + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = - 1.d0 + gutx = bx + guty = by + gutz = bz + guxx = 1.d0 - bx**2 + guyy = 1.d0 - by**2 + guzz = 1.d0 - bz**2 + guxy = - bx * by + guyz = - by * bz + guzx = - bz * bx + + return + end diff --git a/src/metrics/Schwarzschild_PG.F77 b/src/metrics/Schwarzschild_PG.F77 deleted file mode 100644 index e8f21fb..0000000 --- a/src/metrics/Schwarzschild_PG.F77 +++ /dev/null @@ -1,77 +0,0 @@ -c Schwarzschild spacetime in Painleve [e-acute on last e]-Gullstrand -c coordinates. These have a *flat* 3-metric, and are described in -c detail in Martel and Poisson, gr-qc/0001069 -C -C Author: unknown -C Copyright/License: unknown -C -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__Schwarzschild_PG( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL eps, m - CCTK_REAL r, bx, by, bz, b2 - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution. - - eps = Schwarzschild_PG__epsilon - m = Schwarzschild_PG__mass - - r = max(sqrt(x**2 + y**2 + z**2), eps) - bx = sqrt(2.d0 * m / r) * x / r - by = sqrt(2.d0 * m / r) * y / r - bz = sqrt(2.d0 * m / r) * z / r - b2 = 2.d0 * m / r - - gdtt = - 1.d0 + b2 - gdtx = bx - gdty = by - gdtz = bz - gdxx = 1.d0 - gdyy = 1.d0 - gdzz = 1.d0 - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = - 1.d0 - gutx = bx - guty = by - gutz = bz - guxx = 1.d0 - bx**2 - guyy = 1.d0 - by**2 - guzz = 1.d0 - bz**2 - guxy = - bx * by - guyz = - by * bz - guzx = - bz * bx - - return - end diff --git a/src/metrics/Thorne_fakebinary.F b/src/metrics/Thorne_fakebinary.F new file mode 100644 index 0000000..b1321fb --- /dev/null +++ b/src/metrics/Thorne_fakebinary.F @@ -0,0 +1,176 @@ +C fakebinary.F +C Bernd Bruegmann, 6/98 +C +C Compute Thorne four-metric that, although not a solution to the +C Einstein equations, has several characteristic features of a binary +C star system. See gr-qc/9808024. +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + + subroutine Exact__Thorne_fakebinary( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz, + $ psi, Tmunu_flag) + + implicit none + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guxz + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + logical firstcall + CCTK_REAL eps, m, a0, Omega0, bround, atype, aretarded + data firstcall /.true./ + save firstcall, eps, m, a0, Omega0, bround, atype, aretarded + +C temps + CCTK_REAL a, Omega, tau, f + CCTK_REAL c, c0, c1, c2, c3 + CCTK_REAL rho, r, sinp, cosp, phi, sint, cost, tx, ty, tz, px, py, pz + CCTK_REAL a2, b2, bx, by, bz, detgd + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C get parameters of the exact solution. + + if (firstcall) then + firstcall = .false. + + eps = Thorne_fakebinary__epsilon + m = Thorne_fakebinary__mass + a0 = Thorne_fakebinary__separation + + Omega0 = Thorne_fakebinary__Omega0 + bround = Thorne_fakebinary__smoothing + + bround = max(bround, eps) + + if (CCTK_Equals(Thorne_fakebinary__atype, "constant").ne.0) then + atype = 0.d0 + elseif (CCTK_Equals(Thorne_fakebinary__atype,"quadrupole").ne.0) then + atype = 1.d0 + else + call CCTK_Warn(0, + $ "Unknown value of parameter Thorne_fakebinary__atype") + endif + + if (Thorne_fakebinary__retarded.ne.0) then + aretarded = 1.d0 + else + aretarded = 0.d0 + endif + end if + +C spherical coordinates + + rho = max(sqrt(x**2 + y**2), eps) + r = sqrt(rho**2 + z**2) + sinp = y / rho + cosp = x / rho + phi = acos(cosp) + sint = rho / r + cost = z / r + tx = cost*cosp + ty = cost*sinp + tz = sint + px = - sinp + py = cosp + pz = 0 + +C distance function a(T-R) + + tau = 5.d0/128.d0 * a0**4 / m**3 + a = a0 * (1.d0 - atype * 4.d0*(t - aretarded*r)/tau)**(0.25d0) + +C orbital frequency Omega(T-R) + + Omega = 0.5d0*(m/a**3)**2 + +C 1/r type potential f + + c = y**2 + z**2 + bround**2; + f = ((x-a)**2 + c)**(-0.5d0) + ((x+a)**2 + c)**(-0.5d0) + +C the three metric, tt part + + c3 = 2.d0*(phi + Omega*r) + c0 = - 4.d0 * m * a**2 * Omega**3 * (Omega*r)**4 + . / (1 + (Omega*r)**2)**(2.5d0) + c1 = (1 + cost**2) * cos(c3) * c0 + c2 = - 2.d0 * cost * sin(c3) * c0 + gdxx = c1 * (tx*tx - px*px) + c2 * (tx*px + px*tx) + gdxy = c1 * (tx*ty - px*py) + c2 * (tx*py + px*ty) + gdxz = c1 * (tx*tz - px*pz) + c2 * (tx*pz + px*tz) + gdyy = c1 * (ty*ty - py*py) + c2 * (ty*py + py*ty) + gdyz = c1 * (ty*tz - py*pz) + c2 * (ty*pz + py*tz) + gdzz = c1 * (tz*tz - pz*pz) + c2 * (tz*pz + pz*tz) + +C the three metric, add conformally flat part + + c = (1.d0 + m * f)**2 + gdxx = gdxx + c + gdyy = gdyy + c + gdzz = gdzz + c + +C the shift vector and covector + + c = (1.d0 - 2*m*a**2/(r**2+a**2) * f) * Omega * rho + bx = c * px + by = c * py + bz = c * pz + gdtx = gdxx*bx + gdxy*by + gdxz*bz + gdty = gdxy*bx + gdyy*by + gdyz*bz + gdtz = gdxz*bx + gdyz*by + gdzz*bz + b2 = gdtx*bx + gdty*by + gdtz*bz + +C lapse squard and time-time component of the four metric + + a2 = (1.d0 - m * f)**2 + gdtt = b2 - a2 + +C done with metric, find its inverse +C inverse three metric + + detgd = -(gdxz**2*gdyy) + 2*gdxy*gdxz*gdyz - gdxx*gdyz**2 + . - gdxy**2*gdzz - gdxx*gdyy*gdzz + guxx = (-gdyz**2 + gdyy*gdzz) / detgd + guxy = (gdxz*gdyz - gdxy*gdzz) / detgd + guxz = (-(gdxz*gdyy) + gdxy*gdyz) / detgd + guyy = (-gdxz**2 + gdxx*gdzz) / detgd + guyz = (gdxy*gdxz - gdxx*gdyz) / detgd + guzz = (-gdxy**2 + gdxx*gdyy) / detgd + +C inverse four metric + + gutt = - 1.d0/a2 + gutx = bx/a2 + guty = by/a2 + gutz = bz/a2 + guxx = guxx - bx*bx/a2 + guxy = guxy - bx*by/a2 + guxz = guxz - bx*bz/a2 + guyy = guyy - by*by/a2 + guyz = guyz - by*bz/a2 + guzz = guzz - bz*bz/a2 + +C done! + return + end diff --git a/src/metrics/Thorne_fakebinary.F77 b/src/metrics/Thorne_fakebinary.F77 deleted file mode 100644 index c04effb..0000000 --- a/src/metrics/Thorne_fakebinary.F77 +++ /dev/null @@ -1,176 +0,0 @@ -C fakebinary.F -C Bernd Bruegmann, 6/98 -C -C Compute Thorne four-metric that, although not a solution to the -C Einstein equations, has several characteristic features of a binary -C star system. See gr-qc/9808024. -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - - subroutine Exact__Thorne_fakebinary( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz, - $ psi, Tmunu_flag) - - implicit none - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdxz, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guxz - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - logical firstcall - CCTK_REAL eps, m, a0, Omega0, bround, atype, aretarded - data firstcall /.true./ - save firstcall, eps, m, a0, Omega0, bround, atype, aretarded - -C temps - CCTK_REAL a, Omega, tau, f - CCTK_REAL c, c0, c1, c2, c3 - CCTK_REAL rho, r, sinp, cosp, phi, sint, cost, tx, ty, tz, px, py, pz - CCTK_REAL a2, b2, bx, by, bz, detgd - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C get parameters of the exact solution. - - if (firstcall) then - firstcall = .false. - - eps = Thorne_fakebinary__epsilon - m = Thorne_fakebinary__mass - a0 = Thorne_fakebinary__separation - - Omega0 = Thorne_fakebinary__Omega0 - bround = Thorne_fakebinary__smoothing - - bround = max(bround, eps) - - if (CCTK_Equals(Thorne_fakebinary__atype, "constant").ne.0) then - atype = 0.d0 - elseif (CCTK_Equals(Thorne_fakebinary__atype,"quadrupole").ne.0) then - atype = 1.d0 - else - call CCTK_Warn(0, - $ "Unknown value of parameter Thorne_fakebinary__atype") - endif - - if (Thorne_fakebinary__retarded.ne.0) then - aretarded = 1.d0 - else - aretarded = 0.d0 - endif - end if - -C spherical coordinates - - rho = max(sqrt(x**2 + y**2), eps) - r = sqrt(rho**2 + z**2) - sinp = y / rho - cosp = x / rho - phi = acos(cosp) - sint = rho / r - cost = z / r - tx = cost*cosp - ty = cost*sinp - tz = sint - px = - sinp - py = cosp - pz = 0 - -C distance function a(T-R) - - tau = 5.d0/128.d0 * a0**4 / m**3 - a = a0 * (1.d0 - atype * 4.d0*(t - aretarded*r)/tau)**(0.25d0) - -C orbital frequency Omega(T-R) - - Omega = 0.5d0*(m/a**3)**2 - -C 1/r type potential f - - c = y**2 + z**2 + bround**2; - f = ((x-a)**2 + c)**(-0.5d0) + ((x+a)**2 + c)**(-0.5d0) - -C the three metric, tt part - - c3 = 2.d0*(phi + Omega*r) - c0 = - 4.d0 * m * a**2 * Omega**3 * (Omega*r)**4 - . / (1 + (Omega*r)**2)**(2.5d0) - c1 = (1 + cost**2) * cos(c3) * c0 - c2 = - 2.d0 * cost * sin(c3) * c0 - gdxx = c1 * (tx*tx - px*px) + c2 * (tx*px + px*tx) - gdxy = c1 * (tx*ty - px*py) + c2 * (tx*py + px*ty) - gdxz = c1 * (tx*tz - px*pz) + c2 * (tx*pz + px*tz) - gdyy = c1 * (ty*ty - py*py) + c2 * (ty*py + py*ty) - gdyz = c1 * (ty*tz - py*pz) + c2 * (ty*pz + py*tz) - gdzz = c1 * (tz*tz - pz*pz) + c2 * (tz*pz + pz*tz) - -C the three metric, add conformally flat part - - c = (1.d0 + m * f)**2 - gdxx = gdxx + c - gdyy = gdyy + c - gdzz = gdzz + c - -C the shift vector and covector - - c = (1.d0 - 2*m*a**2/(r**2+a**2) * f) * Omega * rho - bx = c * px - by = c * py - bz = c * pz - gdtx = gdxx*bx + gdxy*by + gdxz*bz - gdty = gdxy*bx + gdyy*by + gdyz*bz - gdtz = gdxz*bx + gdyz*by + gdzz*bz - b2 = gdtx*bx + gdty*by + gdtz*bz - -C lapse squard and time-time component of the four metric - - a2 = (1.d0 - m * f)**2 - gdtt = b2 - a2 - -C done with metric, find its inverse -C inverse three metric - - detgd = -(gdxz**2*gdyy) + 2*gdxy*gdxz*gdyz - gdxx*gdyz**2 - . - gdxy**2*gdzz - gdxx*gdyy*gdzz - guxx = (-gdyz**2 + gdyy*gdzz) / detgd - guxy = (gdxz*gdyz - gdxy*gdzz) / detgd - guxz = (-(gdxz*gdyy) + gdxy*gdyz) / detgd - guyy = (-gdxz**2 + gdxx*gdzz) / detgd - guyz = (gdxy*gdxz - gdxx*gdyz) / detgd - guzz = (-gdxy**2 + gdxx*gdyy) / detgd - -C inverse four metric - - gutt = - 1.d0/a2 - gutx = bx/a2 - guty = by/a2 - gutz = bz/a2 - guxx = guxx - bx*bx/a2 - guxy = guxy - bx*by/a2 - guxz = guxz - bx*bz/a2 - guyy = guyy - by*by/a2 - guyz = guyz - by*bz/a2 - guzz = guzz - bz*bz/a2 - -C done! - return - end diff --git a/src/metrics/anti_de_Sitter_Lambda.F b/src/metrics/anti_de_Sitter_Lambda.F new file mode 100644 index 0000000..03cbcc3 --- /dev/null +++ b/src/metrics/anti_de_Sitter_Lambda.F @@ -0,0 +1,72 @@ +C Anti DeSitter metric spacetime with csomological constant +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__anti_de_Sitter_Lambda( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL arad + CCTK_REAL am + +C This model has a cosmological constant + Tmunu_flag = .true. + + arad = anti_de_Sitter_Lambda__scale + + am=exp(2.0D0*sqrt(-arad/3.0D0)*x) + + gdtt = -am + gdtx = 0.0D0 + gdty = 0.0D0 + gdtz = 0.0D0 + gdxx = 1.0D0 + gdyy = am + gdzz = am + gdxy = 0.0D0 + gdyz = 0.0D0 + gdzx = 0.0D0 + + gutt = -1.0D0/am + gutx = 0.0D0 + guty = 0.0D0 + gutz = 0.0D0 + guxx = 1.0D0 + guyy = 1.0D0/am + guzz = 1.0D0/am + guxy = 0.0D0 + guyz = 0.0D0 + guzx = 0.0D0 + + + return + end diff --git a/src/metrics/anti_de_Sitter_Lambda.F77 b/src/metrics/anti_de_Sitter_Lambda.F77 deleted file mode 100644 index dea8898..0000000 --- a/src/metrics/anti_de_Sitter_Lambda.F77 +++ /dev/null @@ -1,69 +0,0 @@ -C Anti DeSitter metric spacetime with csomological constant -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__anti_de_Sitter_Lambda( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL arad - CCTK_REAL am - -C This model has a cosmological constant - Tmunu_flag = .true. - - arad = anti_de_Sitter_Lambda__scale - - am=exp(2.0D0*sqrt(-arad/3.0D0)*x) - - gdtt = -am - gdtx = 0.0D0 - gdty = 0.0D0 - gdtz = 0.0D0 - gdxx = 1.0D0 - gdyy = am - gdzz = am - gdxy = 0.0D0 - gdyz = 0.0D0 - gdzx = 0.0D0 - - gutt = -1.0D0/am - gutx = 0.0D0 - guty = 0.0D0 - gutz = 0.0D0 - guxx = 1.0D0 - guyy = 1.0D0/am - guzz = 1.0D0/am - guxy = 0.0D0 - guyz = 0.0D0 - guzx = 0.0D0 - - - return - end diff --git a/src/metrics/boost_rotation_symmetric.F b/src/metrics/boost_rotation_symmetric.F new file mode 100644 index 0000000..4d34b21 --- /dev/null +++ b/src/metrics/boost_rotation_symmetric.F @@ -0,0 +1,172 @@ +c Boost-Rotation symmetric metric +c see Pravda and Pravdova [a-acute accent on last a], gr-qc/0003067 +C +C Author: unknown +C Copyright/License: unknown +C +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__boost_rotation_symmetric( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c functions local to this file + CCTK_REAL gfunc + +c local variables + CCTK_REAL h, d, numlim + CCTK_REAL a, b, mu0, mu1, lam1, mu2, lam2, + $ lam3, mu4, lam4, mu5, lam5, num, div, f, + $ elam, emu0, delta, tmp + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +C Get parameters of the exact solution. + + h = boost_rotation_symmetric__scale + d = boost_rotation_symmetric__amp + numlim = boost_rotation_symmetric__min_d + +C Intermediate quantities. + + a = x**2 + y**2 + b = z**2 - t**2 + + num = (0.5d0 * (a + b) - h)**2 + 2.d0 * h * a + +C Make sure we are not sitting on one of the two source wordlines, +C given by x = y = 0, z = +/- sqrt(h^2 + t^2) + + if (num / h**4 .le. numlim) then + call CCTK_WARN (0, "too close to source wordline") + end if + + div = 1.d0 / sqrt(num**3) + f = d**2 * ((0.25d0 * (a + b)**2 - h**2)**2 + $ - 0.5d0 * h**2 * a * b) / num**4 + + mu0 = - d * div * (0.5d0 * a**2 + h * a) + mu1 = - d * div * (0.5d0 * b + a - h) + lam1 = d * div * (0.5d0 * b - h) - a * f + mu2 = gfunc(b, mu1) + lam2 = gfunc(b, lam1) + + lam3 = d * div * (0.5d0 * b**2 - h * b) + lam4 = - d * div * (0.5d0 * a + h) - b * f + mu4 = - d * div * (0.5d0 * a + b + h) + mu5 = gfunc(a, - mu4) + lam5 = gfunc(a, lam4) + + elam = exp(lam3 + a * lam4) + emu0 = exp(mu0) + delta = exp(lam3) * (mu5 - lam5) + +C All nonvanishing metric coefficients (downstairs). + + gdxx = elam + y**2 * Delta + gdyy = elam + x**2 * Delta + gdxy = - x * y * Delta + gdzz = emu0 * (1.d0 + lam2 * z**2 - mu2 * t**2) + gdtz = - emu0 * z * t * (lam2 - mu2) + gdtt = - emu0 * (1.d0 + mu2 * z**2 - lam2 * t**2) + +C Others. + + gdzx = 0.d0 + gdyz = 0.d0 + gdtx = 0.d0 + gdty = 0.d0 + +C It is clear that the 3-metric is always spacelike in the xy plane. So +C we only need to check that gdzz is positive. + + if (gdzz .le. 0.d0) then + write(*,*) 'WARNING 3-metric not spacelike in boostrot at' + write(*,*) 't =', t, 'z =', z + write(*,*) 'x =', x, 'y =', y + call CCTK_WARN (0, "aborting") + end if + +C Calculate inverse metric. That is not too difficult as it is +c in block-diagonal form. + + tmp = gdtt * gdzz - gdtz**2 + + if (tmp .eq. 0.d0) then + call CCTK_WARN (0, "boostrot metric inverse failed in tz plane") + end if + + gutt = gdzz / tmp + guzz = gdtt / tmp + gutz = - gdtz / tmp + + tmp = gdxx * gdyy - gdxy**2 + + if (tmp .eq. 0.d0) then + call CCTK_WARN (0, "boostrot metric inverse failed in xy plane") + end if + + guxx = gdyy / tmp + guyy = gdxx / tmp + guxy = - gdxy / tmp + + guzx = 0.d0 + guyz = 0.d0 + gutx = 0.d0 + guty = 0.d0 + + return + end + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +C Calculates g = [exp (x f) - 1] / x as a power series for small x, +C so that the expression is regular at x = 0. + + CCTK_REAL function gfunc(x, f) + + implicit none + + integer n + + CCTK_REAL x, f + CCTK_REAL sum, tmp + + if (abs(x*f) .ge. 1.d-6) then + gfunc = (exp(x*f) - 1.d0) / x + else + sum = 0.d0 + tmp = f + do n=1,10 + tmp = tmp / dble(n) + sum = sum + tmp + tmp = tmp * x * f + end do + gfunc = sum + end if + + return + end diff --git a/src/metrics/boost_rotation_symmetric.F77 b/src/metrics/boost_rotation_symmetric.F77 deleted file mode 100644 index 85f303d..0000000 --- a/src/metrics/boost_rotation_symmetric.F77 +++ /dev/null @@ -1,172 +0,0 @@ -c Boost-Rotation symmetric metric -c see Pravda and Pravdova [a-acute accent on last a], gr-qc/0003067 -C -C Author: unknown -C Copyright/License: unknown -C -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__boost_rotation_symmetric( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c functions local to this file - CCTK_REAL gfunc - -c local variables - CCTK_REAL h, d, numlim - CCTK_REAL a, b, mu0, mu1, lam1, mu2, lam2, - $ lam3, mu4, lam4, mu5, lam5, num, div, f, - $ elam, emu0, delta, tmp - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -C Get parameters of the exact solution. - - h = boost_rotation_symmetric__scale - d = boost_rotation_symmetric__amp - numlim = boost_rotation_symmetric__min_d - -C Intermediate quantities. - - a = x**2 + y**2 - b = z**2 - t**2 - - num = (0.5d0 * (a + b) - h)**2 + 2.d0 * h * a - -C Make sure we are not sitting on one of the two source wordlines, -C given by x = y = 0, z = +/- sqrt(h^2 + t^2) - - if (num / h**4 .le. numlim) then - call CCTK_WARN (0, "too close to source wordline") - end if - - div = 1.d0 / sqrt(num**3) - f = d**2 * ((0.25d0 * (a + b)**2 - h**2)**2 - $ - 0.5d0 * h**2 * a * b) / num**4 - - mu0 = - d * div * (0.5d0 * a**2 + h * a) - mu1 = - d * div * (0.5d0 * b + a - h) - lam1 = d * div * (0.5d0 * b - h) - a * f - mu2 = gfunc(b, mu1) - lam2 = gfunc(b, lam1) - - lam3 = d * div * (0.5d0 * b**2 - h * b) - lam4 = - d * div * (0.5d0 * a + h) - b * f - mu4 = - d * div * (0.5d0 * a + b + h) - mu5 = gfunc(a, - mu4) - lam5 = gfunc(a, lam4) - - elam = exp(lam3 + a * lam4) - emu0 = exp(mu0) - delta = exp(lam3) * (mu5 - lam5) - -C All nonvanishing metric coefficients (downstairs). - - gdxx = elam + y**2 * Delta - gdyy = elam + x**2 * Delta - gdxy = - x * y * Delta - gdzz = emu0 * (1.d0 + lam2 * z**2 - mu2 * t**2) - gdtz = - emu0 * z * t * (lam2 - mu2) - gdtt = - emu0 * (1.d0 + mu2 * z**2 - lam2 * t**2) - -C Others. - - gdzx = 0.d0 - gdyz = 0.d0 - gdtx = 0.d0 - gdty = 0.d0 - -C It is clear that the 3-metric is always spacelike in the xy plane. So -C we only need to check that gdzz is positive. - - if (gdzz .le. 0.d0) then - write(*,*) 'WARNING 3-metric not spacelike in boostrot at' - write(*,*) 't =', t, 'z =', z - write(*,*) 'x =', x, 'y =', y - call CCTK_WARN (0, "aborting") - end if - -C Calculate inverse metric. That is not too difficult as it is -c in block-diagonal form. - - tmp = gdtt * gdzz - gdtz**2 - - if (tmp .eq. 0.d0) then - call CCTK_WARN (0, "boostrot metric inverse failed in tz plane") - end if - - gutt = gdzz / tmp - guzz = gdtt / tmp - gutz = - gdtz / tmp - - tmp = gdxx * gdyy - gdxy**2 - - if (tmp .eq. 0.d0) then - call CCTK_WARN (0, "boostrot metric inverse failed in xy plane") - end if - - guxx = gdyy / tmp - guyy = gdxx / tmp - guxy = - gdxy / tmp - - guzx = 0.d0 - guyz = 0.d0 - gutx = 0.d0 - guty = 0.d0 - - return - end - -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -C Calculates g = [exp (x f) - 1] / x as a power series for small x, -C so that the expression is regular at x = 0. - - CCTK_REAL function gfunc(x, f) - - implicit none - - integer n - - CCTK_REAL x, f - CCTK_REAL sum, tmp - - if (abs(x*f) .ge. 1.d-6) then - gfunc = (exp(x*f) - 1.d0) / x - else - sum = 0.d0 - tmp = f - do n=1,10 - tmp = tmp / dble(n) - sum = sum + tmp - tmp = tmp * x * f - end do - gfunc = sum - end if - - return - end diff --git a/src/metrics/bowl.F b/src/metrics/bowl.F new file mode 100644 index 0000000..9ae4edf --- /dev/null +++ b/src/metrics/bowl.F @@ -0,0 +1,262 @@ +c The metric given here is not a solution of +c Einsteins equations! It is nevertheless +c useful for tests since it has a particularly +c nice geometry. It is a static, spherically +c symmetric metric with no shift. +c +c In spherical coordinates, the metric has the +c form: +c +c 2 2 2 2 +c ds = dr + R(r) d Omega +c +c Clearly, r measures radial proper distance, and R(r) +c is the areal (Schwarzschild) radius. +c +c I choose a form of R(r) such that: +c +c R --> r r<<1, r>>1 +c +c So close in, and far away we have a flat metric. +c In the middle region, I take R to be smaller than +c r, but still larger than zero. This deficit in +c areal radius produces the geometry of a "bag of gold". +c +c The size of the deviation from a flat geometry +c is controled by the parameter "bowl__strength". +c If this parameter is 0, we are in flat space. +c The width of the curved region is controled by +c the paramter "bowl__sigma", and the place where the +c curvature becomes significant (the center of the +c deformation) is controled by "bowl__center". +c +c The specific form of the function R(r) is: +c +c R(r) = ( r - a f(r) ) +c +c and the form of thr function f(r) depends on the +c parameter bowl__shape: +c 2 2 2 +c bowl__shape = "Gaussian" f(r) = exp(-(r-c) / s ) +c +c bowl__shape = "Fermi" f(r) = 1 / ( 1 + exp(-s(r-c)) ) +c +c There are three extra paramters +c (bowl__x_scale,bowl__y_scale,bowl__z_scale) that set the +c scales for the (x,y,z) axis respectively. Their default +c value are all 1. These parameters are useful to hide the +c spherical symmetry of the metric. +C +C Author: unknown +C Copyright/License: unknown +c +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Functions.h" + + subroutine Exact__bowl( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local static variables + logical firstcall,evolve + integer type + CCTK_REAL a,c,s + CCTK_REAL dx,dy,dz + CCTK_REAL t0,st + data firstcall /.true./ + save firstcall,evolve,type,a,c,s,dx,dy,dz,t0,st +c$omp threadprivate (firstcall,evolve,type,a,c,s,dx,dy,dz,t0,st) + +c local variables + character*100 warn_buffer + + CCTK_REAL r,r2,rr2 + CCTK_REAL xr,yr,zr,xr2,yr2,zr2 + CCTK_REAL fac,det + CCTK_REAL tfac + +c constants + CCTK_REAL zero,one,two + parameter (zero=0.0d0, one=1.0d0, two=2.0d0) + +C This is a vacuum spacetime with no cosmological constant + Tmunu_flag = .false. + +c Get parameters of the metric. + + if (firstcall) then + + a = bowl__strength + c = bowl__center + s = bowl__sigma + + dx = bowl__x_scale + dy = bowl__y_scale + dz = bowl__z_scale + + if (CCTK_Equals(bowl__shape,"Gaussian").ne.0) then + type = 1 + else if (CCTK_Equals(bowl__shape,"Fermi").ne.0) then + type = 2 + else + write (warn_buffer, '(a,a,a)') + $ 'Unknown bowl__shape = "', bowl__shape, '"' + call CCTK_WARN(0, warn_buffer) + end if + + if (bowl__evolve.eq.1) then + evolve = .true. + t0 = bowl__t0 + st = bowl__sigma_t + else + evolve = .false. + end if + + firstcall = .false. + + end if + +c Multiply the bowl strength "a" with a time evolution factor. +c The time evolution factor is taken to be a Fermi step centered +c in "t0" and with a width "st". The size of this step is always +c 1 so that far in the past we will always have flat space, and +c far in the future we will have the static bowl. + + if (evolve) then + tfac = one/(one + exp(-st*(t-t0))) + else + tfac = one + end if + + a = a*tfac + +c Find {r2,r}. + + r2 = (x/dx)**2 + (y/dy)**2 + (z/dz)**2 + r = sqrt(r2) + +c Find the form function rr2 +c +c 2 2 2 +c rr2 = (r - a f) / r = (1 - a f / r) + + if (type.eq.1) then + +c Gaussian bowl: +c 2 2 2 +c rr2 = [ 1 - a exp(-(r-c) /s ) / r ] +c +c Notice that this really does not go to 1 at the +c origin. To fix this, I multiply the gaussian +c with the factor: +c +c fac = 1 - sech(4r) +c +c This goes smoothly to 0 at the origin, and climbs +c fast to a limiting value of 1 (at r=1 it is already +c equal to 0.96). + + fac = one - two/(exp(4.0d0*r) + exp(-4.0d0*r)) + rr2 = (one - a*fac*exp(-((r-c)/s)**2)/r)**2 + + else if (type.eq.2) then + +c Fermi bowl: +c 2 +c rr2 = [ 1 - 1 / ( 1 + exp(-s(r-c)) ) / r ] +c +c Again, this doesnt really go to 1 at the origin, so +c I use the same trick as above. + + fac = one - two/(exp(4.0d0*r) + exp(-4.0d0*r)) + rr2 = (one - a*fac/(one + exp(-s*(r-c)))/r)**2 + + else + write (warn_buffer, '(a,i8)') + $ 'Unknown type = ', type +c silence compiler warning about uninitialized variable + rr2 = one + call CCTK_WARN(0, warn_buffer) + + end if + +c Give metric components. + + gdtt = - one + gdtx = zero + gdty = zero + gdtz = zero + + if (r.ne.0) then + + xr = (x/dx)/r + yr = (y/dy)/r + zr = (z/dz)/r + + xr2 = xr**2 + yr2 = yr**2 + zr2 = zr**2 + + gdxx = (xr2 + rr2*(yr2 + zr2))/dx**2 + gdyy = (yr2 + rr2*(xr2 + zr2))/dy**2 + gdzz = (zr2 + rr2*(xr2 + yr2))/dz**2 + + gdxy = xr*yr*(one - rr2)/(dx*dy) + gdyz = yr*zr*(one - rr2)/(dy*dz) + gdzx = xr*zr*(one - rr2)/(dx*dz) + + else + + gdxx = one + gdyy = one + gdzz = one + + gdxy = zero + gdyz = zero + gdzx = zero + + end if + +c Find inverse metric. + + gutt = - one + gutx = zero + guty = zero + gutz = zero + + det = gdxx*gdyy*gdzz + two*gdxy*gdzx*gdyz + . - gdxx*gdyz**2 - gdyy*gdzx**2 - gdzz*gdxy**2 + + guxx = (gdyy*gdzz - gdyz**2)/det + guyy = (gdxx*gdzz - gdzx**2)/det + guzz = (gdxx*gdyy - gdxy**2)/det + + guxy = (gdzx*gdyz - gdzz*gdxy)/det + guyz = (gdxy*gdzx - gdxx*gdyz)/det + guzx = (gdxy*gdyz - gdyy*gdzx)/det + + return + end diff --git a/src/metrics/bowl.F77 b/src/metrics/bowl.F77 deleted file mode 100644 index 5592dd1..0000000 --- a/src/metrics/bowl.F77 +++ /dev/null @@ -1,260 +0,0 @@ -c The metric given here is not a solution of -c Einsteins equations! It is nevertheless -c useful for tests since it has a particularly -c nice geometry. It is a static, spherically -c symmetric metric with no shift. -c -c In spherical coordinates, the metric has the -c form: -c -c 2 2 2 2 -c ds = dr + R(r) d Omega -c -c Clearly, r measures radial proper distance, and R(r) -c is the areal (Schwarzschild) radius. -c -c I choose a form of R(r) such that: -c -c R --> r r<<1, r>>1 -c -c So close in, and far away we have a flat metric. -c In the middle region, I take R to be smaller than -c r, but still larger than zero. This deficit in -c areal radius produces the geometry of a "bag of gold". -c -c The size of the deviation from a flat geometry -c is controled by the parameter "bowl__strength". -c If this parameter is 0, we are in flat space. -c The width of the curved region is controled by -c the paramter "bowl__sigma", and the place where the -c curvature becomes significant (the center of the -c deformation) is controled by "bowl__center". -c -c The specific form of the function R(r) is: -c -c R(r) = ( r - a f(r) ) -c -c and the form of thr function f(r) depends on the -c parameter bowl__shape: -c 2 2 2 -c bowl__shape = "Gaussian" f(r) = exp(-(r-c) / s ) -c -c bowl__shape = "Fermi" f(r) = 1 / ( 1 + exp(-s(r-c)) ) -c -c There are three extra paramters -c (bowl__x_scale,bowl__y_scale,bowl__z_scale) that set the -c scales for the (x,y,z) axis respectively. Their default -c value are all 1. These parameters are useful to hide the -c spherical symmetry of the metric. -C -C Author: unknown -C Copyright/License: unknown -c -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Functions.h" - - subroutine Exact__bowl( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local static variables - logical firstcall,evolve - integer type - CCTK_REAL a,c,s - CCTK_REAL dx,dy,dz - CCTK_REAL t0,st - data firstcall /.true./ - save firstcall,evolve,type,a,c,s,dx,dy,dz,t0,st -c$omp threadprivate (firstcall,evolve,type,a,c,s,dx,dy,dz,t0,st) - -c local variables - character*100 warn_buffer - - CCTK_REAL r,r2,rr2 - CCTK_REAL xr,yr,zr,xr2,yr2,zr2 - CCTK_REAL fac,det - CCTK_REAL tfac - -c constants - CCTK_REAL zero,one,two - parameter (zero=0.0d0, one=1.0d0, two=2.0d0) - -C This is a vacuum spacetime with no cosmological constant - Tmunu_flag = .false. - -c Get parameters of the metric. - - if (firstcall) then - - a = bowl__strength - c = bowl__center - s = bowl__sigma - - dx = bowl__x_scale - dy = bowl__y_scale - dz = bowl__z_scale - - if (CCTK_Equals(bowl__shape,"Gaussian").ne.0) then - type = 1 - else if (CCTK_Equals(bowl__shape,"Fermi").ne.0) then - type = 2 - else - write (warn_buffer, '(a,a,a)') - $ 'Unknown bowl__shape = "', bowl__shape, '"' - call CCTK_WARN(0, warn_buffer) - end if - - if (bowl__evolve.eq.1) then - evolve = .true. - t0 = bowl__t0 - st = bowl__sigma_t - else - evolve = .false. - end if - - firstcall = .false. - - end if - -c Multiply the bowl strength "a" with a time evolution factor. -c The time evolution factor is taken to be a Fermi step centered -c in "t0" and with a width "st". The size of this step is always -c 1 so that far in the past we will always have flat space, and -c far in the future we will have the static bowl. - - if (evolve) then - tfac = one/(one + exp(-st*(t-t0))) - else - tfac = one - end if - - a = a*tfac - -c Find {r2,r}. - - r2 = (x/dx)**2 + (y/dy)**2 + (z/dz)**2 - r = sqrt(r2) - -c Find the form function rr2 -c -c 2 2 2 -c rr2 = (r - a f) / r = (1 - a f / r) - - if (type.eq.1) then - -c Gaussian bowl: -c 2 2 2 -c rr2 = [ 1 - a exp(-(r-c) /s ) / r ] -c -c Notice that this really does not go to 1 at the -c origin. To fix this, I multiply the gaussian -c with the factor: -c -c fac = 1 - sech(4r) -c -c This goes smoothly to 0 at the origin, and climbs -c fast to a limiting value of 1 (at r=1 it is already -c equal to 0.96). - - fac = one - two/(exp(4.0d0*r) + exp(-4.0d0*r)) - rr2 = (one - a*fac*exp(-((r-c)/s)**2)/r)**2 - - else if (type.eq.2) then - -c Fermi bowl: -c 2 -c rr2 = [ 1 - 1 / ( 1 + exp(-s(r-c)) ) / r ] -c -c Again, this doesnt really go to 1 at the origin, so -c I use the same trick as above. - - fac = one - two/(exp(4.0d0*r) + exp(-4.0d0*r)) - rr2 = (one - a*fac/(one + exp(-s*(r-c)))/r)**2 - - else - write (warn_buffer, '(a,i8)') - $ 'Unknown type = ', type - call CCTK_WARN(0, warn_buffer) - - end if - -c Give metric components. - - gdtt = - one - gdtx = zero - gdty = zero - gdtz = zero - - if (r.ne.0) then - - xr = (x/dx)/r - yr = (y/dy)/r - zr = (z/dz)/r - - xr2 = xr**2 - yr2 = yr**2 - zr2 = zr**2 - - gdxx = (xr2 + rr2*(yr2 + zr2))/dx**2 - gdyy = (yr2 + rr2*(xr2 + zr2))/dy**2 - gdzz = (zr2 + rr2*(xr2 + yr2))/dz**2 - - gdxy = xr*yr*(one - rr2)/(dx*dy) - gdyz = yr*zr*(one - rr2)/(dy*dz) - gdzx = xr*zr*(one - rr2)/(dx*dz) - - else - - gdxx = one - gdyy = one - gdzz = one - - gdxy = zero - gdyz = zero - gdzx = zero - - end if - -c Find inverse metric. - - gutt = - one - gutx = zero - guty = zero - gutz = zero - - det = gdxx*gdyy*gdzz + two*gdxy*gdzx*gdyz - . - gdxx*gdyz**2 - gdyy*gdzx**2 - gdzz*gdxy**2 - - guxx = (gdyy*gdzz - gdyz**2)/det - guyy = (gdxx*gdzz - gdzx**2)/det - guzz = (gdxx*gdyy - gdxy**2)/det - - guxy = (gdzx*gdyz - gdzz*gdxy)/det - guyz = (gdxy*gdzx - gdxx*gdyz)/det - guzx = (gdxy*gdyz - gdyy*gdzx)/det - - return - end diff --git a/src/metrics/constant_density_star.F b/src/metrics/constant_density_star.F new file mode 100644 index 0000000..3a67c1c --- /dev/null +++ b/src/metrics/constant_density_star.F @@ -0,0 +1,118 @@ +c The metric given here corresponds to a constant +c density star, also known as a "Schwarzschild" star. +c There is corresponding code in +c include/Scalar_CalcTmunu.inc +c to set up the matter variables. +C +c Author: Mitica Vulcanov +C see ../../README for copyright & licensing info +C +c $Header$ + +c +c The metric is given as a conformally flat metric. +c Turns out that in the original areal radius, the +c metric variables have a kink at the surface of the +c star, but they are smooth in the conformal form. +c +c Thanks to Philippos Papadopoulos for suggesting +c the use of this metric. + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__constant_density_star( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z + CCTK_DECLARE(CCTK_REAL, t,) + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL mass,radius + CCTK_REAL r,c,psi4 + +c constants + CCTK_REAL zero,one,two + parameter (zero=0.0d0, one=1.0d0, two=2.0d0) + +c This model has matter +c ==> it sets the stress-energy tensor in the "CalcTmunu" code + Tmunu_flag = .true. + +c Get parameters of the metric. + + mass = constant_density_star__mass + radius = constant_density_star__radius + +c Find r. + + r = sqrt(x**2 + y**2 + z**2) + +c Find conformal factor. + + if (r.le.radius) then + + c = mass/(two*radius) + + psi4 = (one + c)**6/(one + c*(r/radius)**2)**2 + + else + + c = mass/(two*r) + + psi4 = (one + c)**4 + + end if + +c Find metric components. + + gdtt = - psi4 + + gdtx = zero + gdty = zero + gdtz = zero + + gdxx = psi4 + gdyy = psi4 + gdzz = psi4 + + gdxy = zero + gdyz = zero + gdzx = zero + +c Find inverse metric. + + gutt = -one/psi4 + + gutx = zero + guty = zero + gutz = zero + + guxx = one/psi4 + guyy = one/psi4 + guzz = one/psi4 + + guxy = zero + guyz = zero + guzx = zero + + return + end diff --git a/src/metrics/constant_density_star.F77 b/src/metrics/constant_density_star.F77 deleted file mode 100644 index 9543c9b..0000000 --- a/src/metrics/constant_density_star.F77 +++ /dev/null @@ -1,117 +0,0 @@ -c The metric given here corresponds to a constant -c density star, also known as a "Schwarzschild" star. -c There is corresponding code in -c include/Scalar_CalcTmunu.inc -c to set up the matter variables. -C -c Author: Mitica Vulcanov -C see ../../README for copyright & licensing info -C -c $Header$ - -c -c The metric is given as a conformally flat metric. -c Turns out that in the original areal radius, the -c metric variables have a kink at the surface of the -c star, but they are smooth in the conformal form. -c -c Thanks to Philippos Papadopoulos for suggesting -c the use of this metric. - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__constant_density_star( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL mass,radius - CCTK_REAL r,c,psi4 - -c constants - CCTK_REAL zero,one,two - parameter (zero=0.0d0, one=1.0d0, two=2.0d0) - -c This model has matter -c ==> it sets the stress-energy tensor in the "CalcTmunu" code - Tmunu_flag = .true. - -c Get parameters of the metric. - - mass = constant_density_star__mass - radius = constant_density_star__radius - -c Find r. - - r = sqrt(x**2 + y**2 + z**2) - -c Find conformal factor. - - if (r.le.radius) then - - c = mass/(two*radius) - - psi4 = (one + c)**6/(one + c*(r/radius)**2)**2 - - else - - c = mass/(two*r) - - psi4 = (one + c)**4 - - end if - -c Find metric components. - - gdtt = - psi4 - - gdtx = zero - gdty = zero - gdtz = zero - - gdxx = psi4 - gdyy = psi4 - gdzz = psi4 - - gdxy = zero - gdyz = zero - gdzx = zero - -c Find inverse metric. - - gutt = -one/psi4 - - gutx = zero - guty = zero - gutz = zero - - guxx = one/psi4 - guyy = one/psi4 - guzz = one/psi4 - - guxy = zero - guyz = zero - guzx = zero - - return - end diff --git a/src/metrics/de_Sitter.F b/src/metrics/de_Sitter.F new file mode 100644 index 0000000..94901a9 --- /dev/null +++ b/src/metrics/de_Sitter.F @@ -0,0 +1,79 @@ +C Einstein-DeSitter metric spacetime !!!! +C It emulates the Robertson-Walker universe +C near t=0, with zero pressure, and k=0 +C See :J.N. Islam, An Introduction to +C Mathematical Cosmology, Cambridge, 1992 and +C S. Hawking, G.F.R. Ellis, The Large Scale +C Structure of space-time, Cambridge, 1973 +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__de_Sitter( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + CCTK_REAL t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL arad + CCTK_REAL am + +C This model has a cosmological constant +C ==> it sets the stress-energy tensor in the "CalcTmunu" code + Tmunu_flag = .true. + + arad = de_Sitter__scale + + am=arad*t**(4.0D0/3.0D0) + + gdtt = -1.0D0 + gdtx = 0.0D0 + gdty = 0.0D0 + gdtz = 0.0D0 + gdxx = am + gdyy = am + gdzz = am + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = -1.d0 + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = 1.d0/am + guyy = 1.d0/am + guzz = 1.d0/am + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + + return + end diff --git a/src/metrics/de_Sitter.F77 b/src/metrics/de_Sitter.F77 deleted file mode 100644 index e6cb642..0000000 --- a/src/metrics/de_Sitter.F77 +++ /dev/null @@ -1,76 +0,0 @@ -C Einstein-DeSitter metric spacetime !!!! -C It emulates the Robertson-Walker universe -C near t=0, with zero pressure, and k=0 -C See :J.N. Islam, An Introduction to -C Mathematical Cosmology, Cambridge, 1992 and -C S. Hawking, G.F.R. Ellis, The Large Scale -C Structure of space-time, Cambridge, 1973 -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__de_Sitter( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL arad - CCTK_REAL am - -C This model has a cosmological constant -C ==> it sets the stress-energy tensor in the "CalcTmunu" code - Tmunu_flag = .true. - - arad = de_Sitter__scale - - am=arad*t**(4.0D0/3.0D0) - - gdtt = -1.0D0 - gdtx = 0.0D0 - gdty = 0.0D0 - gdtz = 0.0D0 - gdxx = am - gdyy = am - gdzz = am - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = -1.d0 - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = 1.d0/am - guyy = 1.d0/am - guzz = 1.d0/am - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - - return - end diff --git a/src/metrics/de_Sitter_Lambda.F b/src/metrics/de_Sitter_Lambda.F new file mode 100644 index 0000000..f2b613d --- /dev/null +++ b/src/metrics/de_Sitter_Lambda.F @@ -0,0 +1,73 @@ +C DeSitter metric spacetime with cosmological constant +C +C Author : D. Vulcanov (Timisoara, Romania) +C see ../../README for copyright & licensing info +C +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__de_Sitter_Lambda( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_DECLARE(CCTK_REAL, x,) + CCTK_DECLARE(CCTK_REAL, y,) + CCTK_DECLARE(CCTK_REAL, z,) + CCTK_REAL t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local variables + CCTK_REAL arad + CCTK_REAL am + +C This model is non-vacuum +C ==> it sets the stress-energy tensor in the "CalcTmunu" code + Tmunu_flag = .true. + + arad = de_Sitter_Lambda__scale + + am=exp(2.0D0*sqrt(arad/3.0d0)*t) + + gdtt = -1.d0 + gdtx = 0.d0 + gdty = 0.d0 + gdtz = 0.d0 + gdxx = am + gdyy = am + gdzz = am + gdxy = 0.d0 + gdyz = 0.d0 + gdzx = 0.d0 + + gutt = -1.d0 + gutx = 0.d0 + guty = 0.d0 + gutz = 0.d0 + guxx = 1.d0/am + guyy = 1.d0/am + guzz = 1.d0/am + guxy = 0.d0 + guyz = 0.d0 + guzx = 0.d0 + + + return + end diff --git a/src/metrics/de_Sitter_Lambda.F77 b/src/metrics/de_Sitter_Lambda.F77 deleted file mode 100644 index fa507fa..0000000 --- a/src/metrics/de_Sitter_Lambda.F77 +++ /dev/null @@ -1,70 +0,0 @@ -C DeSitter metric spacetime with cosmological constant -C -C Author : D. Vulcanov (Timisoara, Romania) -C see ../../README for copyright & licensing info -C -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__de_Sitter_Lambda( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local variables - CCTK_REAL arad - CCTK_REAL am - -C This model is non-vacuum -C ==> it sets the stress-energy tensor in the "CalcTmunu" code - Tmunu_flag = .true. - - arad = de_Sitter_Lambda__scale - - am=exp(2.0D0*sqrt(arad/3.0d0)*t) - - gdtt = -1.d0 - gdtx = 0.d0 - gdty = 0.d0 - gdtz = 0.d0 - gdxx = am - gdyy = am - gdzz = am - gdxy = 0.d0 - gdyz = 0.d0 - gdzx = 0.d0 - - gutt = -1.d0 - gutx = 0.d0 - guty = 0.d0 - gutz = 0.d0 - guxx = 1.d0/am - guyy = 1.d0/am - guzz = 1.d0/am - guxy = 0.d0 - guyz = 0.d0 - guzx = 0.d0 - - - return - end diff --git a/src/metrics/make.code.defn b/src/metrics/make.code.defn index 1e90de0..c597115 100644 --- a/src/metrics/make.code.defn +++ b/src/metrics/make.code.defn @@ -6,40 +6,40 @@ # ... if adding new files, please keep this list in the same order as the # metrics in this thorn's param.ccl file # -SRCS = Minkowski.F77 \ - Minkowski_funny.F77 \ - Minkowski_shift.F77 \ - Minkowski_gauge_wave.F77 \ - Minkowski_shifted_gauge_wave.F77 \ - Minkowski_conf_wave.F77 \ +SRCS = Minkowski.F \ + Minkowski_funny.F \ + Minkowski_shift.F \ + Minkowski_gauge_wave.F \ + Minkowski_shifted_gauge_wave.F \ + Minkowski_conf_wave.F \ \ - Schwarzschild_EF.F77 \ - Schwarzschild_PG.F77 \ - Schwarzschild_BL.F77 \ - Schwarzschild_Novikov.F77 \ - Kerr_BoyerLindquist.F77 \ - Kerr_KerrSchild.F77 \ - Kerr_KerrSchild_spherical.F77 \ - Schwarzschild_Lemaitre.F77 \ - multi_BH.F77 \ - Thorne_fakebinary.F77 \ + Schwarzschild_EF.F \ + Schwarzschild_PG.F \ + Schwarzschild_BL.F \ + Schwarzschild_Novikov.F \ + Kerr_BoyerLindquist.F \ + Kerr_KerrSchild.F \ + Kerr_KerrSchild_spherical.F \ + Schwarzschild_Lemaitre.F \ + multi_BH.F \ + Thorne_fakebinary.F \ \ - Lemaitre.F77 \ - de_Sitter.F77 \ - de_Sitter_Lambda.F77 \ - anti_de_Sitter_Lambda.F77 \ - Bianchi_I.F77 \ - Goedel.F77 \ - Bertotti.F77 \ - Kasner_like.F77 \ - Kasner_axisymmetric.F77 \ - Kasner_generalized.F77 \ - Gowdy_wave.F77 \ - Milne.F77 \ + Lemaitre.F \ + de_Sitter.F \ + de_Sitter_Lambda.F \ + anti_de_Sitter_Lambda.F \ + Bianchi_I.F \ + Goedel.F \ + Bertotti.F \ + Kasner_like.F \ + Kasner_axisymmetric.F \ + Kasner_generalized.F \ + Gowdy_wave.F \ + Milne.F \ \ - boost_rotation_symmetric.F77 \ - bowl.F77 \ - constant_density_star.F77 + boost_rotation_symmetric.F \ + bowl.F \ + constant_density_star.F # not fully implemented yet -- see Nina Jansen for details -# Alvi.F77 Alvidef.c +# Alvi.F Alvidef.c diff --git a/src/metrics/multi_BH.F b/src/metrics/multi_BH.F new file mode 100644 index 0000000..827dbb7 --- /dev/null +++ b/src/metrics/multi_BH.F @@ -0,0 +1,141 @@ +c======================================================================= +c23456789012345678901234567890123456789012345678901234567890123456789012 +c----------------------------------------------------------------------- +c by Hisaaki Shinkai shinkai@wurel.wustl.edu 19980603 +c----------------------------------------------------------------------- +c This is for maximally charged multi BH solutions such as +c Majumdar-Papapetrou (1947) or Kastor-Traschen (1993) solution. +c See also doc/KTsol.tex for brief review of this solution. +c----------------------------------------------------------------------- +c For usage: in your par file +c Exact::exact_model = "multiBH" +c Exact::multi_BH__Hubble = 0.0 # 0.0 means MP solution +c Exact::multi_BH__nBH = 2 # number of BHs (upto 4, currently) +c m_bh1,multi_BH__x1x,multi_BH__x1y,multi_BH__x1z = 1.0, -2.0,0.0,0.0 # masses and +c m_bh2,multi_BH__x2x,multi_BH__x2y,multi_BH__x2z = 1.0, 2.0,0.0,0.0 # locations +c----------------------------------------------------------------------- +c $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" + + subroutine Exact__multi_BH( + $ x, y, z, t, + $ gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx, + $ psi, Tmunu_flag) + + implicit none + + DECLARE_CCTK_PARAMETERS + +c input arguments + CCTK_REAL x, y, z, t + +c output arguments + CCTK_REAL gdtt, gdtx, gdty, gdtz, + $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, + $ gutt, gutx, guty, gutz, + $ guxx, guyy, guzz, guxy, guyz, guzx + CCTK_DECLARE(CCTK_REAL, psi,) + LOGICAL Tmunu_flag + +c local static variables + logical firstcall + CCTK_REAL kt_xbh(10),kt_ybh(10),kt_zbh(10),kt_mbh(10) + data firstcall /.true./ + save firstcall,kt_xbh,kt_ybh,kt_zbh,kt_mbh + +c local variables + CCTK_REAL kt_r, kt_aa, kt_omega + integer i + +c constants + CCTK_REAL zero,one + parameter (zero=0.0d0, one=1.0d0) + +C This model does not set the stress-energy tensor +C FIXME: should it? I.e. isnt there a nonzero Maxwell tensor here? + Tmunu_flag = .false. + +c Get parameters of the exact solution. + + if (firstcall) then + + write(*,*) ' welcome to Kastor-Traschen (Majumdar-Papapetrou)' + + if(multi_BH__nBH.ge.1) then + kt_xbh(1) = multi_BH__x1 + kt_ybh(1) = multi_BH__y1 + kt_zbh(1) = multi_BH__z1 + kt_mbh(1) = multi_BH__mass1 + endif + + if(multi_BH__nBH.ge.2) then + kt_xbh(2) = multi_BH__x2 + kt_ybh(2) = multi_BH__y2 + kt_zbh(2) = multi_BH__z2 + kt_mbh(1) = multi_BH__mass2 + endif + + if(multi_BH__nBH.ge.3) then + kt_xbh(3) = multi_BH__x3 + kt_ybh(3) = multi_BH__y3 + kt_zbh(3) = multi_BH__z3 + kt_mbh(1) = multi_BH__mass3 + endif + + if(multi_BH__nBH.ge.4) then + kt_xbh(4) = multi_BH__x4 + kt_ybh(4) = multi_BH__y4 + kt_zbh(4) = multi_BH__z4 + kt_mbh(1) = multi_BH__mass4 + endif + + write(*,*) 'time=',t + write(*,*) ' mass BH(x,y,z) ' + + do i=1,multi_BH__nBH + write(*,'(4e12.3)') kt_mbh(i),kt_xbh(i),kt_ybh(i),kt_zbh(i) + enddo + + firstcall = .false. + + end if + + kt_aa=exp(multi_BH__Hubble*t) + kt_omega=1.0 + + do i=1,multi_BH__nBH + kt_r=sqrt((x-kt_xbh(i))**2+(y-kt_ybh(i))**2+(z-kt_zbh(i))**2) + kt_omega= kt_omega+kt_mbh(i)/kt_aa/kt_r + enddo + +c write(*,*) kt_omega,kt_aa + + gdtt = -1.0/kt_omega**2 + gdtx = zero + gdty = zero + gdtz = zero + gdxx = (kt_aa*kt_omega)**2 + gdyy = (kt_aa*kt_omega)**2 + gdzz = (kt_aa*kt_omega)**2 + gdxy = zero + gdyz = zero + gdzx = zero + + gutt = one/gdtt + gutx = zero + guty = zero + gutz = zero + guxx = one/gdxx + guyy = one/gdyy + guzz = one/gdzz + guxy = zero + guyz = zero + guzx = zero + + return + end diff --git a/src/metrics/multi_BH.F77 b/src/metrics/multi_BH.F77 deleted file mode 100644 index 212c41c..0000000 --- a/src/metrics/multi_BH.F77 +++ /dev/null @@ -1,141 +0,0 @@ -c======================================================================= -c23456789012345678901234567890123456789012345678901234567890123456789012 -c----------------------------------------------------------------------- -c by Hisaaki Shinkai shinkai@wurel.wustl.edu 19980603 -c----------------------------------------------------------------------- -c This is for maximally charged multi BH solutions such as -c Majumdar-Papapetrou (1947) or Kastor-Traschen (1993) solution. -c See also doc/KTsol.tex for brief review of this solution. -c----------------------------------------------------------------------- -c For usage: in your par file -c Exact::exact_model = "multiBH" -c Exact::multi_BH__Hubble = 0.0 # 0.0 means MP solution -c Exact::multi_BH__nBH = 2 # number of BHs (upto 4, currently) -c m_bh1,multi_BH__x1x,multi_BH__x1y,multi_BH__x1z = 1.0, -2.0,0.0,0.0 # masses and -c m_bh2,multi_BH__x2x,multi_BH__x2y,multi_BH__x2z = 1.0, 2.0,0.0,0.0 # locations -c----------------------------------------------------------------------- -c $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" - - subroutine Exact__multi_BH( - $ x, y, z, t, - $ gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx, - $ psi, Tmunu_flag) - - implicit none - - DECLARE_CCTK_PARAMETERS - -c input arguments - CCTK_REAL x, y, z, t - -c output arguments - CCTK_REAL gdtt, gdtx, gdty, gdtz, - $ gdxx, gdyy, gdzz, gdxy, gdyz, gdzx, - $ gutt, gutx, guty, gutz, - $ guxx, guyy, guzz, guxy, guyz, guzx - CCTK_REAL psi - LOGICAL Tmunu_flag - -c local static variables - logical firstcall - CCTK_REAL kt_xbh(10),kt_ybh(10),kt_zbh(10),kt_mbh(10) - data firstcall /.true./ - save firstcall,kt_xbh,kt_ybh,kt_zbh,kt_mbh - -c local variables - CCTK_REAL kt_r, kt_aa, kt_omega - integer i - -c constants - CCTK_REAL zero,one - parameter (zero=0.0d0, one=1.0d0) - -C This model does not set the stress-energy tensor -C FIXME: should it? I.e. isnt there a nonzero Maxwell tensor here? - Tmunu_flag = .false. - -c Get parameters of the exact solution. - - if (firstcall) then - - write(*,*) ' welcome to Kastor-Traschen (Majumdar-Papapetrou)' - - if(multi_BH__nBH.ge.1) then - kt_xbh(1) = multi_BH__x1 - kt_ybh(1) = multi_BH__y1 - kt_zbh(1) = multi_BH__z1 - kt_mbh(1) = multi_BH__mass1 - endif - - if(multi_BH__nBH.ge.2) then - kt_xbh(2) = multi_BH__x2 - kt_ybh(2) = multi_BH__y2 - kt_zbh(2) = multi_BH__z2 - kt_mbh(1) = multi_BH__mass2 - endif - - if(multi_BH__nBH.ge.3) then - kt_xbh(3) = multi_BH__x3 - kt_ybh(3) = multi_BH__y3 - kt_zbh(3) = multi_BH__z3 - kt_mbh(1) = multi_BH__mass3 - endif - - if(multi_BH__nBH.ge.4) then - kt_xbh(4) = multi_BH__x4 - kt_ybh(4) = multi_BH__y4 - kt_zbh(4) = multi_BH__z4 - kt_mbh(1) = multi_BH__mass4 - endif - - write(*,*) 'time=',t - write(*,*) ' mass BH(x,y,z) ' - - do i=1,multi_BH__nBH - write(*,'(4e12.3)') kt_mbh(i),kt_xbh(i),kt_ybh(i),kt_zbh(i) - enddo - - firstcall = .false. - - end if - - kt_aa=exp(multi_BH__Hubble*t) - kt_omega=1.0 - - do i=1,multi_BH__nBH - kt_r=sqrt((x-kt_xbh(i))**2+(y-kt_ybh(i))**2+(z-kt_zbh(i))**2) - kt_omega= kt_omega+kt_mbh(i)/kt_aa/kt_r - enddo - -c write(*,*) kt_omega,kt_aa - - gdtt = -1.0/kt_omega**2 - gdtx = zero - gdty = zero - gdtz = zero - gdxx = (kt_aa*kt_omega)**2 - gdyy = (kt_aa*kt_omega)**2 - gdzz = (kt_aa*kt_omega)**2 - gdxy = zero - gdyz = zero - gdzx = zero - - gutt = one/gdtt - gutx = zero - guty = zero - gutz = zero - guxx = one/gdxx - guyy = one/gdyy - guzz = one/gdzz - guxy = zero - guyz = zero - guzx = zero - - return - end diff --git a/src/slice_data.F b/src/slice_data.F index 3ade6f5..c8b49c1 100644 --- a/src/slice_data.F +++ b/src/slice_data.F @@ -13,13 +13,13 @@ C $Header$ c #define-ing the symbol EXACT_NO_F90 will turn this subroutine into a no-op #ifndef EXACT_NO_F90 - integer i, j, k, l, m, n, p, q, s + integer i, j, k, l, m, n, p, q integer nx,ny,nz integer ierr CCTK_REAL s1d(4,3), nd(4), nu(4), norm, gd(4,4), gu(4,4), g3(3,3), $ gd_p(4,4), gd_m(4,4), gd1d(4,4,4), s2d(4,3,3), k3(3,3), - $ ex_eps, d3(3,3,3), dx, dy, dz, exact_psi + $ ex_eps, dx, dy, dz, exact_psi parameter (ex_eps=1.d-6) C Grid parameters. diff --git a/src/xyz_blended_boundary.F b/src/xyz_blended_boundary.F new file mode 100644 index 0000000..06db214 --- /dev/null +++ b/src/xyz_blended_boundary.F @@ -0,0 +1,238 @@ +C $Header$ + +#include "cctk.h" +#include "cctk_Parameters.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" + + subroutine Exact__xyz_blended_boundary(CCTK_ARGUMENTS) + + implicit none + + DECLARE_CCTK_ARGUMENTS + DECLARE_CCTK_PARAMETERS + DECLARE_CCTK_FUNCTIONS + + logical doKij, doGij, doLapse, doShift + + integer i,j,k + integer nx,ny,nz + integer ninterps + + CCTK_REAL xblend, yblend, zblend + CCTK_REAL xmin, xmax, ymin, ymax, zmin, zmax + CCTK_REAL xfrac, yfrac, zfrac, onemxfrac, onemyfrac, onemzfrac + CCTK_REAL oonints + CCTK_REAL sfrac, onemsfrac + CCTK_REAL gxxe, gyye, gzze, gxye, gyze, gxze + CCTK_REAL kxxe, kyye, kzze, kxye, kyze, kxze + CCTK_REAL dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze + CCTK_REAL dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze + CCTK_REAL dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze + CCTK_REAL alpe, dtalpe, axe, aye, aze + CCTK_REAL betaxe,betaye,betaze, dtbetaxe,dtbetaye,dtbetaze + CCTK_REAL bxxe,bxye,bxze,byxe,byye,byze,bzxe,bzye,bzze + CCTK_REAL det, uxx, uxy, uxz, uyy, uyz, uzz + CCTK_REAL + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz + + CCTK_REAL dx,dy,dz,time + integer ierr + +C Grid parameters. + + nx = cctk_lsh(1) + ny = cctk_lsh(2) + nz = cctk_lsh(3) + + dx = cctk_delta_space(1) + dy = cctk_delta_space(2) + dz = cctk_delta_space(3) + + time = cctk_time + +C Other parameters. + + doKij = (exblend_Ks.eq.1) + doGij = (exblend_gs.eq.1) + + doLapse = ((exblend_gauge.eq.1).and. + $ (CCTK_Equals(lapse_evolution_method,"exact").ne.0)) + doShift = ((exblend_gauge.eq.1).and. + $ (CCTK_Equals(shift_evolution_method,"exact").ne.0)) + + if (exblend_width.lt.0) then + xblend = - exblend_width*dx + yblend = - exblend_width*dy + zblend = - exblend_width*dz + else + xblend = exblend_width + yblend = exblend_width + zblend = exblend_width + endif + + call CCTK_CoordRange(ierr,cctkGH,xmin,xmax,-1,"x","cart3d") + call CCTK_CoordRange(ierr,cctkGH,ymin,ymax,-1,"y","cart3d") + call CCTK_CoordRange(ierr,cctkGH,zmin,zmax,-1,"z","cart3d") + + do k=1,nz + do j=1,ny + do i=1,nx + +c We only do anything if in the blending region + + if (x(i,j,k) .ge. xmax - xblend .or. + $ x(i,j,k) .le. xmin + xblend .or. + $ y(i,j,k) .ge. ymax - yblend .or. + $ y(i,j,k) .le. ymin + yblend .or. + $ z(i,j,k) .ge. zmax - zblend .or. + $ z(i,j,k) .le. zmin + zblend) then + +C Initialize the psi of exact +C (also to tell the models about the conformal_state) + if (conformal_state .ne. 0) then + exact_psi = 1.0D0 + else + exact_psi = 0.0D0 + end if + exact_psix = 0.0D0 + exact_psiy = 0.0D0 + exact_psiz = 0.0D0 + exact_psixx = 0.0D0 + exact_psiyy = 0.0D0 + exact_psizz = 0.0D0 + exact_psixy = 0.0D0 + exact_psiyz = 0.0D0 + exact_psixz = 0.0D0 + + call Exact__Bona_Masso_data( + $ decoded_exact_model, + $ x(i,j,k), y(i,j,k), z(i,j,k), time, + $ gxxe, gyye, gzze, gxye, gyze, gxze, + $ kxxe, kyye, kzze, kxye, kyze, kxze, + $ exact_psi, + $ exact_psix, exact_psiy, exact_psiz, + $ exact_psixx, exact_psiyy, exact_psizz, + $ exact_psixy, exact_psiyz, exact_psixz, + $ dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze, + $ dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze, + $ dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze, + $ alpe, dtalpe, axe, aye, aze, + $ betaxe, betaye, betaze, dtbetaxe, dtbetaye, dtbetaze, + $ bxxe, bxye, bxze, byxe, + $ byye, byze, bzxe, bzye, bzze) + +c This sucks, but we want the exact vs so we can blend them also. + + det = -(gxze**2*gyye) + & + 2.d0*gxye*gxze*gyze + & - gxxe*gyze**2 + & - gxye**2*gzze + & + gxxe*gyye*gzze + + uxx=(-gyze**2 + gyye*gzze)/det + uxy=(gxze*gyze - gxye*gzze)/det + uyy=(-gxze**2 + gxxe*gzze)/det + uxz=(-gxze*gyye + gxye*gyze)/det + uyz=(gxye*gxze - gxxe*gyze)/det + uzz=(-gxye**2 + gxxe*gyye)/det + +c OK so 6 blending cases. If frac = 1 we get all exact + + ninterps = 0 + + xfrac = 0.0D0 + onemxfrac = 0.0D0 + yfrac = 0.0D0 + onemyfrac = 0.0D0 + zfrac = 0.0D0 + onemzfrac = 0.0D0 + + if (x(i,j,k) .le. xmin + xblend) then + xfrac = 1.0D0 - (x(i,j,k)-xmin) / xblend + onemxfrac = 1.0D0 - xfrac + ninterps = ninterps + 1 + endif + + if (x(i,j,k) .ge. xmax - xblend) then + xfrac = 1.0D0 - (xmax - x(i,j,k)) / xblend + onemxfrac = 1.0D0 - xfrac + ninterps = ninterps + 1 + endif + + if (y(i,j,k) .le. ymin + yblend) then + yfrac = 1.0D0 - (y(i,j,k)-ymin) / yblend + onemyfrac = 1.0D0 - yfrac + ninterps = ninterps + 1 + endif + + if (y(i,j,k) .ge. ymax - yblend) then + yfrac = 1.0D0 - (ymax - y(i,j,k)) / yblend + onemyfrac = 1.0D0 - yfrac + ninterps = ninterps + 1 + endif + + if (z(i,j,k) .le. zmin + zblend) then + zfrac = 1.0D0 - (z(i,j,k)-zmin) / zblend + onemzfrac = 1.0D0 - zfrac + ninterps = ninterps + 1 + endif + + if (z(i,j,k) .ge. zmax - zblend) then + zfrac = 1.0D0 - (zmax - z(i,j,k)) / zblend + onemzfrac = 1.0D0 - zfrac + ninterps = ninterps + 1 + endif + + oonints = 1.0D0 / ninterps + + if (ninterps .eq. 0 .or. ninterps .gt. 3) then + print *,"NINTERPS error", ninterps + call CCTK_WARN (0, "aborting") + endif + + sfrac = (xfrac + yfrac + zfrac) * oonints + onemsfrac = 1.0D0 - sfrac + +c Once again some c-preprocessor tricks based on the whole fortran +c space thing... + +#define INTPOINT(f,v) f(i,j,k) = sfrac * v + onemsfrac * f(i,j,k) +#define intone(f) INTPOINT(f, f e) +#define int_grp(p) \ + intone(p xx) &&\ + intone(p xy) &&\ + intone(p xz) &&\ + intone(p yy) &&\ + intone(p yz) &&\ + intone(p zz) + + if (doGij) then + int_grp(g) + endif + + if (doKij) then + int_grp(k) + endif + + if (doLapse) then + intone(alp) + endif + + if (doShift.and.(shift_state.ne.0)) then + intone(betax) + intone(betay) + intone(betaz) + endif + + endif ! r > rinner + + enddo + enddo + enddo + + return + end diff --git a/src/xyz_blended_boundary.F77 b/src/xyz_blended_boundary.F77 deleted file mode 100644 index 06db214..0000000 --- a/src/xyz_blended_boundary.F77 +++ /dev/null @@ -1,238 +0,0 @@ -C $Header$ - -#include "cctk.h" -#include "cctk_Parameters.h" -#include "cctk_Arguments.h" -#include "cctk_Functions.h" - - subroutine Exact__xyz_blended_boundary(CCTK_ARGUMENTS) - - implicit none - - DECLARE_CCTK_ARGUMENTS - DECLARE_CCTK_PARAMETERS - DECLARE_CCTK_FUNCTIONS - - logical doKij, doGij, doLapse, doShift - - integer i,j,k - integer nx,ny,nz - integer ninterps - - CCTK_REAL xblend, yblend, zblend - CCTK_REAL xmin, xmax, ymin, ymax, zmin, zmax - CCTK_REAL xfrac, yfrac, zfrac, onemxfrac, onemyfrac, onemzfrac - CCTK_REAL oonints - CCTK_REAL sfrac, onemsfrac - CCTK_REAL gxxe, gyye, gzze, gxye, gyze, gxze - CCTK_REAL kxxe, kyye, kzze, kxye, kyze, kxze - CCTK_REAL dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze - CCTK_REAL dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze - CCTK_REAL dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze - CCTK_REAL alpe, dtalpe, axe, aye, aze - CCTK_REAL betaxe,betaye,betaze, dtbetaxe,dtbetaye,dtbetaze - CCTK_REAL bxxe,bxye,bxze,byxe,byye,byze,bzxe,bzye,bzze - CCTK_REAL det, uxx, uxy, uxz, uyy, uyz, uzz - CCTK_REAL - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz - - CCTK_REAL dx,dy,dz,time - integer ierr - -C Grid parameters. - - nx = cctk_lsh(1) - ny = cctk_lsh(2) - nz = cctk_lsh(3) - - dx = cctk_delta_space(1) - dy = cctk_delta_space(2) - dz = cctk_delta_space(3) - - time = cctk_time - -C Other parameters. - - doKij = (exblend_Ks.eq.1) - doGij = (exblend_gs.eq.1) - - doLapse = ((exblend_gauge.eq.1).and. - $ (CCTK_Equals(lapse_evolution_method,"exact").ne.0)) - doShift = ((exblend_gauge.eq.1).and. - $ (CCTK_Equals(shift_evolution_method,"exact").ne.0)) - - if (exblend_width.lt.0) then - xblend = - exblend_width*dx - yblend = - exblend_width*dy - zblend = - exblend_width*dz - else - xblend = exblend_width - yblend = exblend_width - zblend = exblend_width - endif - - call CCTK_CoordRange(ierr,cctkGH,xmin,xmax,-1,"x","cart3d") - call CCTK_CoordRange(ierr,cctkGH,ymin,ymax,-1,"y","cart3d") - call CCTK_CoordRange(ierr,cctkGH,zmin,zmax,-1,"z","cart3d") - - do k=1,nz - do j=1,ny - do i=1,nx - -c We only do anything if in the blending region - - if (x(i,j,k) .ge. xmax - xblend .or. - $ x(i,j,k) .le. xmin + xblend .or. - $ y(i,j,k) .ge. ymax - yblend .or. - $ y(i,j,k) .le. ymin + yblend .or. - $ z(i,j,k) .ge. zmax - zblend .or. - $ z(i,j,k) .le. zmin + zblend) then - -C Initialize the psi of exact -C (also to tell the models about the conformal_state) - if (conformal_state .ne. 0) then - exact_psi = 1.0D0 - else - exact_psi = 0.0D0 - end if - exact_psix = 0.0D0 - exact_psiy = 0.0D0 - exact_psiz = 0.0D0 - exact_psixx = 0.0D0 - exact_psiyy = 0.0D0 - exact_psizz = 0.0D0 - exact_psixy = 0.0D0 - exact_psiyz = 0.0D0 - exact_psixz = 0.0D0 - - call Exact__Bona_Masso_data( - $ decoded_exact_model, - $ x(i,j,k), y(i,j,k), z(i,j,k), time, - $ gxxe, gyye, gzze, gxye, gyze, gxze, - $ kxxe, kyye, kzze, kxye, kyze, kxze, - $ exact_psi, - $ exact_psix, exact_psiy, exact_psiz, - $ exact_psixx, exact_psiyy, exact_psizz, - $ exact_psixy, exact_psiyz, exact_psixz, - $ dxgxxe, dxgyye, dxgzze, dxgxye, dxgyze, dxgxze, - $ dygxxe, dygyye, dygzze, dygxye, dygyze, dygxze, - $ dzgxxe, dzgyye, dzgzze, dzgxye, dzgyze, dzgxze, - $ alpe, dtalpe, axe, aye, aze, - $ betaxe, betaye, betaze, dtbetaxe, dtbetaye, dtbetaze, - $ bxxe, bxye, bxze, byxe, - $ byye, byze, bzxe, bzye, bzze) - -c This sucks, but we want the exact vs so we can blend them also. - - det = -(gxze**2*gyye) - & + 2.d0*gxye*gxze*gyze - & - gxxe*gyze**2 - & - gxye**2*gzze - & + gxxe*gyye*gzze - - uxx=(-gyze**2 + gyye*gzze)/det - uxy=(gxze*gyze - gxye*gzze)/det - uyy=(-gxze**2 + gxxe*gzze)/det - uxz=(-gxze*gyye + gxye*gyze)/det - uyz=(gxye*gxze - gxxe*gyze)/det - uzz=(-gxye**2 + gxxe*gyye)/det - -c OK so 6 blending cases. If frac = 1 we get all exact - - ninterps = 0 - - xfrac = 0.0D0 - onemxfrac = 0.0D0 - yfrac = 0.0D0 - onemyfrac = 0.0D0 - zfrac = 0.0D0 - onemzfrac = 0.0D0 - - if (x(i,j,k) .le. xmin + xblend) then - xfrac = 1.0D0 - (x(i,j,k)-xmin) / xblend - onemxfrac = 1.0D0 - xfrac - ninterps = ninterps + 1 - endif - - if (x(i,j,k) .ge. xmax - xblend) then - xfrac = 1.0D0 - (xmax - x(i,j,k)) / xblend - onemxfrac = 1.0D0 - xfrac - ninterps = ninterps + 1 - endif - - if (y(i,j,k) .le. ymin + yblend) then - yfrac = 1.0D0 - (y(i,j,k)-ymin) / yblend - onemyfrac = 1.0D0 - yfrac - ninterps = ninterps + 1 - endif - - if (y(i,j,k) .ge. ymax - yblend) then - yfrac = 1.0D0 - (ymax - y(i,j,k)) / yblend - onemyfrac = 1.0D0 - yfrac - ninterps = ninterps + 1 - endif - - if (z(i,j,k) .le. zmin + zblend) then - zfrac = 1.0D0 - (z(i,j,k)-zmin) / zblend - onemzfrac = 1.0D0 - zfrac - ninterps = ninterps + 1 - endif - - if (z(i,j,k) .ge. zmax - zblend) then - zfrac = 1.0D0 - (zmax - z(i,j,k)) / zblend - onemzfrac = 1.0D0 - zfrac - ninterps = ninterps + 1 - endif - - oonints = 1.0D0 / ninterps - - if (ninterps .eq. 0 .or. ninterps .gt. 3) then - print *,"NINTERPS error", ninterps - call CCTK_WARN (0, "aborting") - endif - - sfrac = (xfrac + yfrac + zfrac) * oonints - onemsfrac = 1.0D0 - sfrac - -c Once again some c-preprocessor tricks based on the whole fortran -c space thing... - -#define INTPOINT(f,v) f(i,j,k) = sfrac * v + onemsfrac * f(i,j,k) -#define intone(f) INTPOINT(f, f e) -#define int_grp(p) \ - intone(p xx) &&\ - intone(p xy) &&\ - intone(p xz) &&\ - intone(p yy) &&\ - intone(p yz) &&\ - intone(p zz) - - if (doGij) then - int_grp(g) - endif - - if (doKij) then - int_grp(k) - endif - - if (doLapse) then - intone(alp) - endif - - if (doShift.and.(shift_state.ne.0)) then - intone(betax) - intone(betay) - intone(betaz) - endif - - endif ! r > rinner - - enddo - enddo - enddo - - return - end -- cgit v1.2.3