From 16725b4c9678c22bf1c23b9c40970a0798735a80 Mon Sep 17 00:00:00 2001 From: schnetter Date: Sat, 19 Jun 2004 16:26:56 +0000 Subject: A new excision thorn. git-svn-id: http://svn.einsteintoolkit.org/cactus/EinsteinInitialData/NoExcision/trunk@2 4ec1db94-0e4f-0410-ada3-8bed251432c9 --- src/make.code.defn | 8 +++++ src/overwrite.F90 | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+) create mode 100644 src/make.code.defn create mode 100644 src/overwrite.F90 (limited to 'src') diff --git a/src/make.code.defn b/src/make.code.defn new file mode 100644 index 0000000..7dd625c --- /dev/null +++ b/src/make.code.defn @@ -0,0 +1,8 @@ +# Main make.code.defn file for thorn NoExcision +# $Header$ + +# Source files in this directory +SRCS = overwrite.F90 + +# Subdirectories containing source files +SUBDIRS = diff --git a/src/overwrite.F90 b/src/overwrite.F90 new file mode 100644 index 0000000..c7949ae --- /dev/null +++ b/src/overwrite.F90 @@ -0,0 +1,88 @@ +! $Header$ + +#include "cctk.h" +#include "cctk_Arguments.h" +#include "cctk_Functions.h" +#include "cctk_Parameters.h" + +subroutine NoExcision_Overwrite (CCTK_ARGUMENTS) + implicit none + DECLARE_CCTK_ARGUMENTS + DECLARE_CCTK_FUNCTIONS + DECLARE_CCTK_PARAMETERS + + CCTK_REAL :: cx, cy, cz, rad + integer :: n + + do n = 1, num_regions + + cx = centre_x(n) + cy = centre_y(n) + cz = centre_z(n) + rad = radius(n) + + if (overwrite_geometry /= 0) then + + if (conformal_state >= 1) then + where ((x - cx)**2 + (y - cy)**2 + (z - cz)**2 <= rad**2) + psi = 1 + end where + end if + if (conformal_state >= 2) then + where ((x - cx)**2 + (y - cy)**2 + (z - cz)**2 <= rad**2) + psix = 0 + psiy = 0 + psiz = 0 + end where + end if + if (conformal_state >= 3) then + where ((x - cx)**2 + (y - cy)**2 + (z - cz)**2 <= rad**2) + psixx = 0 + psixy = 0 + psixz = 0 + psiyy = 0 + psiyz = 0 + psizz = 0 + end where + end if + + where ((x - cx)**2 + (y - cy)**2 + (z - cz)**2 <= rad**2) + gxx = 1 + gxy = 0 + gxz = 0 + gyy = 1 + gyz = 0 + gzz = 1 + kxx = 0 + kxy = 0 + kxz = 0 + kyy = 0 + kyz = 0 + kzz = 0 + end where + + end if + + if (overwrite_lapse /= 0) then + + where ((x - cx)**2 + (y - cy)**2 + (z - cz)**2 <= rad**2) + alp = 1 + end where + + end if + + if (overwrite_shift /= 0) then + + if (shift_state /= 0) then + where ((x - cx)**2 + (y - cy)**2 + (z - cz)**2 <= rad**2) + betax = 0 + betay = 0 + betaz = 0 + end where + end if + + end if + + end do + +end subroutine NoExcision_Overwrite -- cgit v1.2.3